home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr51 / lib201.zip / FILES.PRG < prev    next >
Text File  |  1993-04-27  |  135KB  |  3,677 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: FILES.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 03/24/1993
  5. *-- Notes.....: These are file processing routines. To see how to use this 
  6. *--             library file, see: README.TXT.
  7. *-------------------------------------------------------------------------------
  8.  
  9. PROCEDURE AllTags
  10. *-------------------------------------------------------------------------------
  11. *-- Programmer..: Susan Perschke (SPECDATA) and Michael Liczbanski (LMIKE)
  12. *-- Date........: 01/03/1992
  13. *-- Notes.......: Used to bring up a list of MDX tags on screen for the user,
  14. *--               so they can change the current tag ... This was gotten to me
  15. *--               by Steve (LTI), from "Data Based Advisor", December, 1991.
  16. *-- Written for.: dBASE IV, 1.1
  17. *-- Rev. History: 12/15/1991 - original procedure.
  18. *--               01/03/1992 - Ken Mayer -- added shadow ...
  19. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  20. *-- Called by...: Any
  21. *-- Usage.......: DO AllTags WITH nULRow, nULCol
  22. *-- Example.....: ON KEY LABEL F8 DO ALLTAGS WITH 02,60
  23. *-- Returns.....: None
  24. *-- Parameters..: nULRow -- Starting Row for Popup
  25. *--               nULCol -- Starting Column for Popup
  26. *-------------------------------------------------------------------------------
  27.  
  28.     parameters nULRow, nULCol
  29.     private nBar, cPrompt, nBRRow, nBRCol
  30.     
  31.     *-- Disable left/right arrow keys to prevent an accidental exit
  32.     on key label leftarrow  ?? chr(7)
  33.     on key label rightarrow ?? chr(7)
  34.     
  35.     *-- Save current screen
  36.     save screen to sTag
  37.     activate screen
  38.     
  39.     *-- define the popup
  40.     define popup pTag from nULRow, nULCol;
  41.        message " Press ENTER to select new index order...ESC to exit..."
  42.     nBar = 1                        && first bar
  43.     cPrompt    = "-No Index-"       &&  will always be this
  44.     
  45.     *-- loop to get the rest of 'em ...
  46.     do while "" <> cPrompt          && loop until no more tags
  47.         define bar nBar of pTag prompt (cPrompt)
  48.         cPrompt = tag(nBar)
  49.         nBar = nBar + 1
  50.     enddo
  51.     
  52.     on selection popup pTag deactivate popup
  53.     
  54.     *-- process shadow
  55.     nBRRow = nULRow+(nBar-1)+1 && bottom right for shadow (1 for t/b of pop)
  56.     nBRCol = nULCol+11         && bottom right for shadow (2 for sides,
  57.                    &&   +9 for tagnames)
  58.     do shadow with nULRow,nULCol,nBRRow,nBRCol
  59.     
  60.     *-- do it
  61.     activate popup pTag
  62.     
  63.     *-- Assign a null string to cPrompt if "No Index" selected
  64.     cPrompt = iif(bar() = 1, "",prompt())
  65.     
  66.     *-- Don't change index order if ESC pressed
  67.     if bar() <> 0
  68.        set order to (cPrompt)
  69.     endif
  70.     
  71.     *-- cleanup
  72.     release popup pTag
  73.     restore screen from sTag
  74.     release screen sTag
  75.     
  76.     *-- Enable left/right arrow keys
  77.     on key label leftarrow
  78.     on key label rightarrow
  79.  
  80. RETURN
  81. *-- EoP: AllTags
  82.  
  83. PROCEDURE MakeTagFl
  84. *-------------------------------------------------------------------------------
  85. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  86. *-- Date........: 04/15/1992
  87. *-- Notes.......: Build a .dbf file from scratch, without using CREATE FROM.
  88. *--               The file built has three fields, TAGS1, TAGS2 and TAGS3,
  89. *--               each character-type and 254 bytes wide.
  90. *-- Written for.: dBASE IV, 1.1
  91. *-- Rev. History: Broken out of other code and date-writing added
  92. *--               by Jay Parsons, 4/15/1992
  93. *--             : Originally from the program PRGCREAT.ZIP
  94. *-- Called by...: Any
  95. *-- Usage.......: do MakeTagFl WITH "<cFname>"
  96. *-- Example.....: do MakeTagFl WITH "Tags"
  97. *-- Returns.....: None
  98. *-- Parameters..: cFname, name of the .dbf to create
  99. *-- Side effects: Creates a .dbf and overwrites any existing one of same name
  100. *--             : Disables external setting of PRINTER
  101. *-------------------------------------------------------------------------------
  102.     parameters cFname
  103.     private cName
  104.     cName = cFname
  105.     if .not. "." $ cName
  106.        cName = cName + ".DBF"
  107.     endif
  108.     set printer to file ( cName )
  109.     set printer on
  110.     ??? "{3}"
  111.     ??? chr( year( date() - 1900 ) )
  112.     ??? chr( month( date() ) )
  113.     ??? chr( day( date() ) )
  114.     ??? "{0}{0}{0}{0}{129}{0}{251}{2}{0}{0}{0}{0}"
  115.     ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{201}{0}"
  116.     ??? "{84}{65}{71}{83}{49}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags1
  117.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  118.     ??? "{84}{65}{71}{83}{50}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags2
  119.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  120.     ??? "{84}{65}{71}{83}{51}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags3
  121.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  122.     ??? "{13}{26}"
  123.     set printer off
  124.     set printer to
  125.  
  126. RETURN
  127. *-- EoP: MakeTagFl
  128.  
  129. PROCEDURE RedoTags
  130. *-------------------------------------------------------------------------------
  131. *-- Programmer..: David Love (CIS: 70153,2433)
  132. *-- Date........: 04/18/1992
  133. *-- Notes.......: This routine is a "generic" MDX cleanup routine. It is useful
  134. *--               for handling "bloated" MDX files -- ones that have been around
  135. *--               awhile (they tend to be larger than necessary). This routine
  136. *--               will store the tag keys in an array, delete the tags, and then
  137. *--               rebuild the MDX file from scratch, keeping all tag names and
  138. *--               keys, and the MDX SHOULD be smaller.
  139. *--             : Will act on the dbf's production mdx (ie. same name as dbf)
  140. *-- Written for.: dBASE IV, 1.5
  141. *-- Rev. History: 01/20/1992 - original function for dBASE IV Ver. 1.1.
  142. *--               04/18/1992 - David Love - adapted for use with beta version
  143. *--                 of dBASE IV, version 1.5.
  144. *--               (TAGCOUNT(), FOR(), DESCENDING(), UNIQUE() are 1.5 functions)
  145. *-- Calls.......: None
  146. *-- Called by...: Any
  147. *-- Usage.......: do RedoTags with "<cDBF>"
  148. *-- Example.....: do RedoTags with "Referral"
  149. *-- Returns.....: None
  150. *-- Parameters..: cDBF = Name of DATABASE file, no extension necessary.
  151. *-------------------------------------------------------------------------------
  152.  
  153.     parameter cDBF
  154.     
  155.     use (cDBF) excl
  156.     
  157.     *-- First, figure out how many tags exist
  158.  
  159.     private nMaxTags
  160.     nMaxTags = tagcount( cDBF,1 )
  161.     
  162.     *-- only perform routine if an index tag exists
  163.     if nMaxTags > 0
  164.       private nTags, mkey, mtag
  165.     
  166.       *-- store the keys and tags to an array
  167.       declare aTags[nMaxTags,5]
  168.        nTags = 1
  169.       do while nTags <= nMaxTags
  170.     store key( (cDBF),nTags) to aTags[nTags,1]        && grab the key
  171.     store tag( (cDBF),nTags) to aTags[nTags,2]        && grab the tagname
  172.     store for( (cDBF),nTags) to aTags[nTags,3]        && grab the for clause
  173.     store descending( (cDBF),nTags) to aTags[nTags,4] && .t. if descending
  174.     store unique( (cDBF),nTags) to aTags[nTags,5]     && .t. if unique
  175.         nTags = nTags + 1
  176.       enddo
  177.     
  178.        *-- now, delete the tags   
  179.        do while "" # tag( (cDBF),1)
  180.      delete tag tag( (cDBF),1)
  181.        enddo
  182.       
  183.        *-- rebuild the MDX, tag by tag ...
  184.        nTags = 1
  185.       do while nTags <= nMaxTags
  186.     mkey = aTags[nTags,1]+iif(""#aTags[nTags,3]," for "+aTags[nTags,3],"") ;
  187.       + iif(aTags[nTags,4]," DESCENDING","") ;
  188.       + iif(aTags[nTags,5]," UNIQUE","")
  189.          mtag = aTags[nTags,2]
  190.     index on &mkey. tag &mtag.
  191.          nTags = nTags + 1
  192.       enddo
  193.     
  194.        *-- release the array ...
  195.       release aTags
  196.     
  197.     endif  && check for tags ...
  198.     use    && close database
  199.     
  200. RETURN
  201. *-- EoP: RedoTags
  202.  
  203. PROCEDURE AutoRedo
  204. *------------------------------------------------------------------------------
  205. *-- Programmer..: Douglas P. Saine (CIS: 74660,3574)
  206. *-- Date........: 03/06/1992
  207. *-- Notes.......: Displays a popup to choose a DBF from the current directory
  208. *--               to re-build its MDX file
  209. *-- Written for.: dBASE IV, 1.1
  210. *-- Rev. History: 03/04/1992 - original procedure.
  211. *--               03/06/1992 -- Ken Mayer added color parameter,
  212. *--                shadow to popup, and erase DBFS.DBF datafile at end.
  213. *-- Calls.......: LISTDBFS             Procedure in FILES.PRG
  214. *--               REDOTAGS             Procedure in FILES.PRG
  215. *--               CENTER               Procedure in PROC.PRG
  216. *--               YESNO2()             Function in PROC.PRG
  217. *--               SHADOW               Procedure in PROC.PRG       
  218. *--               EXTRCLR()            Function in PROC.PRG
  219. *-- Called by...: Any
  220. *-- Usage.......: do AutoRedo with nXTL,nYTL,nXBR,nYBR,cColor
  221. *-- Example.....: do AutoRedo with 5,34,15,47,"rg+/gb,w+/n,rg+/gb"
  222. *-- Returns.....: None
  223. *-- Parameters..: None
  224. *------------------------------------------------------------------------------
  225.  
  226.     parameters nXTL, nYTL, nXBR, nYBR, cColor
  227.     
  228.     *-- Save Environment
  229.     cTalk = set("talk")
  230.     cStat = set("status")
  231.     cCloc = set("clock")
  232.     cScor = set("scoreboard")
  233.     cSafe = set("safety")
  234.     
  235.     *-- Set Environment
  236.     set stat off
  237.     set talk off
  238.     set cloc off
  239.     set scor off
  240.     set safe off
  241.     
  242.     *-- Full Screen Window for screen restoration when finished
  243.     define window wCoverScr from 0,0 to 23,79 none
  244.     activate window wCoverScr
  245.     clear
  246.     
  247.     *-- Make a Data File of the Current Directory
  248.     do center with 10,80,extrclr('&cColor'),;
  249.         '... Making Data File from Current Directory ...'
  250.     do ListDBFs
  251.     
  252.     use DBFS
  253.     index on DBFS->DBF tag IORDER
  254.     
  255.     *-- Define and access the popup of DataFiles
  256.     activate screen
  257.     define popup uDbfList from nXTL,nYTL to nXBR,nYBR prompt field DBFS->DBF
  258.     on selection popup uDbfList deactivate popup
  259.     
  260.     *-- Execute loop for multiple re-indexes
  261.     clear
  262.     lLoop = .t.
  263.     do while lLoop
  264.         do shadow with nXTL,nYTL,nXBR,nYBR
  265.        activate popup uDbfList
  266.         clear  && get rid of shadow
  267.         
  268.        *--  Record the prompt() and remove '.dbf' so it works with Redotag
  269.        cDataFile = substr(prompt(),1,len(trim(prompt()))-4)
  270.     
  271.        *-- Verify the MDX exists
  272.        if file(cDataFile+'.mdx')
  273.           do redotags with cDataFile
  274.        else
  275.           do center with 10,80,extrclr("&cColor"),;
  276.         '... Production MDX file not found for file '+cDataFile
  277.           n = inkey(0)
  278.           clear
  279.        endif
  280.     
  281.        *-- Determine if the user wants to re-build another
  282.        if YesNo2(.t.,"CC","",;
  283.           "Do you wish to reindex another file?","","&cColor")
  284.           use DBFS order IORDER
  285.        else
  286.           lLoop = .f.
  287.        endif
  288.     
  289.     enddo
  290.     
  291.     *-- Restore environment
  292.     use DBFS
  293.     delete tag IORDER
  294.     use
  295.     erase DBFS.DBF
  296.     release popup uDbfList
  297.     deactivate window wCoverScr
  298.     release window wCoverScr
  299.     set stat &cStat
  300.     set talk &cTalk
  301.     set cloc &cCloc
  302.     set scor &cScor
  303.     set safe &cSafe
  304.     
  305. RETURN
  306. *-- EoP:  AutoRedo
  307.  
  308. PROCEDURE PrntTags
  309. *-------------------------------------------------------------------------------
  310. *-- Programmer..: David Love (CIS: 70153,2433)
  311. *-- Date........: 03/24/1993
  312. *-- Notes.......: This routine is a "quick and not-so-dirty" method of printing
  313. *--               the tag and key expressions for a dbf's production mdx file.
  314. *--               It obviates the need for DISP/LIST STAT TO PRINT (or DISP STAT
  315. *--               followed by SHIFT+PrtScr).
  316. *--               This code is modified from the procedure RedoTags.prg,
  317. *--               previously posted on the BORBBS.
  318. *--             : The proc will print the full key expression, including
  319. *--               FOR/DESCENDING/UNIQUE options, if present.
  320. *-- Written for.: dBASE IV, 1.1
  321. *-- Rev. History: 01/31/1992 - original procedure written for dBASE IV, Ver. 1.1
  322. *--               04/18/1992 - David Love - revised for version 1.5
  323. *--               03/24/1993 - Lee Hite - modified so that wild card specs
  324. *--                            may now be used to list multiple .DBF's.
  325. *--                            also, added optional parameter to include file
  326. *--                            structure in output.
  327. *-- Calls.......: ADIR()               Function in FILES.PRG
  328. *--               PARSPATH()           Function in FILES.PRG
  329. *--               SHELLSORT()          Function in ARRAY.PRG
  330. *--               NOTE: These routines are called only when using wildcards.
  331. *-- Called by...: Any
  332. *-- Usage.......: do PrntTags with "<cDBF>",[lDispStru]
  333. *-- Example.....: do PrntTags with "Referral"
  334. *--               do PrntTags with "*.dbf",.t.
  335. *-- Returns.....: None
  336. *-- Parameters..: cDBF      = Name of DATABASE file, may include wildcard specs
  337. *--                           (i.e., "REF*").  No extension is necessary, but
  338. *--                           if it's there, it better be ".DBF" <g>
  339. *--               lDispStru = [optional] set to .T. to include the file
  340. *--                           structure in the output
  341. *-------------------------------------------------------------------------------
  342.  
  343.     parameter cDBFParm,lDispStru
  344.  
  345.     private cTalk
  346.     cTalk = set("TALK")
  347.     set talk off
  348.     set printer on
  349.  
  350.     *-- handle whether or not we got a wild card
  351.     private cDBFPath,cDBFMask,nDBFs,aMyArray,lDummy,nKntr
  352.     if "*" $ cDBFParm .or. "?" $ cDBFParm
  353.        *-- wildcards, so build an array of the file names
  354.        cDBFMask = iif(at(".DBF",upper(cDBFParm))>0,cDBFParm,cDBFParm+".DBF")
  355.        nDBFs = aDir(cDBFMask,"","")
  356.        if nDBFs > 0
  357.           declare aMyArray[nDBFs,1]
  358.           nKntr = 1
  359.           do while nKntr <= nDBFs
  360.              aMyArray[nKntr,1] = gaDir[nKntr,1]
  361.              nKntr = nKntr + 1
  362.           enddo
  363.           lDummy = ShellSort(nDBFs)
  364.        endif
  365.        cDBFPath = ParsPath(cDBFMask)
  366.     else
  367.        *-- no wild cards, so we just have one entry in the array
  368.        private aMyArray
  369.        declare aMyArray[1,1]
  370.        aMyArray[1,1] = upper(cDBFParm)
  371.        nDBFs = 1
  372.        cDBFPath = ""
  373.     endif
  374.  
  375.     *-- loop for each .DBF
  376.     private cDBF,nKntr
  377.     nKntr = 1
  378.     do while nKntr <= nDBFs
  379.       cDBF = aMyArray[nKntr,1]
  380.       *-- pull extension out of file name so TAGCOUNT(), etc. work...
  381.       cDBF = iif(at(".DBF",cDBF)=0,cDBF,left(cDBF,at(".DBF",cDBF)-1))
  382.       use (cDBFPath+cDBF)
  383.       ?? "DATABASE: "+cDBF at 0
  384.       ?
  385.       ?
  386.  
  387.       *-- display file structure if optioned
  388.       if lDispStru
  389.          ?? "STRUCTURE:" at 0
  390.          disp stru
  391.          ?
  392.       endif
  393.     
  394.       *-- now, figure out how many tags exist
  395.       private nMaxTags
  396.       nMaxTags = tagcount( cDBF )
  397.       ?? "INDEX TAGS:" at 0
  398.       ?
  399.     
  400.       *-- only perform routine if an index tag exists
  401.       if nMaxTags > 0
  402.         private nTags, mkey, mtag
  403.  
  404.         *-- store the keys and tags to an array
  405.         declare aTags[nMaxTags,5]
  406.         nTags = 1
  407.         do while nTags <= nMaxTags
  408.           store key( (cDBF),nTags) to aTags[nTags,1]        && grab the key
  409.           store tag( (cDBF),nTags) to aTags[nTags,2]        && grab the tagname
  410.           store for( (cDBF),nTags) to aTags[nTags,3]        && grab the for clause
  411.           store descending( (cDBF),nTags) to aTags[nTags,4] && .t. if descending
  412.           store unique( (cDBF),nTags) to aTags[nTags,5]     && .t. if unique
  413.           nTags = nTags + 1
  414.         enddo
  415.  
  416.         *-- print each tag with it's key expression
  417.         ?? "Tag" at 0
  418.         ?? "Key Expression" AT 12
  419.         ?
  420.         nTags = 1
  421.         do while nTags <= nMaxTags
  422.           ?? aTags[nTags,2] AT 0
  423.           ?? aTags[nTags,1] + ;
  424.           iif(""#aTags[nTags,3]," FOR "+aTags[nTags,3],"") + ;
  425.           iif(aTags[nTags,4]," DESCENDING","") + ;
  426.           iif(aTags[nTags,5]," UNIQUE","") AT 12
  427.           ?
  428.           nTags = nTags + 1
  429.         enddo
  430.  
  431.         *-- release the array ...
  432.         release aTags
  433.  
  434.       else
  435.         *-- no tags found
  436.         ?? "none" at 0
  437.         ?
  438.       endif  && check for tags ...
  439.       use    && close database
  440.       ?? replicate("=",60) at 0
  441.       ?
  442.       nKntr = nKntr + 1
  443.  
  444.     enddo  && loop for each .dbf
  445.  
  446.     *-- restore the environment
  447.     release gaDir
  448.     set printer off
  449.     set talk &cTalk
  450.     
  451. RETURN
  452. *-- EoP: PrntTags
  453.  
  454. PROCEDURE ListDBFs
  455. *-------------------------------------------------------------------------------
  456. *-- Programmer..: David Love (70153,2433)
  457. *-- Date........: 01/31/1992
  458. *-- Notes.......: This procedure will create a list of the database (.dbf) files
  459. *--               in the current directory.  It will create a database file
  460. *--               named Dbfs.dbf which exists of one 12-character field--Dbf.
  461. *--               It will also create a text file, Dbfs.txt, through the
  462. *--               LIST FILES to FILE command.  Then it will append records
  463. *--               to the Dbfs.dbf file and erase the Dbfs.txt file.
  464. *--             : This Dbfs.dbf file can be SCANned, or used in a POPUP PROMPT
  465. *--               FIELD command, or in any way that you can imagine.
  466. *--             : The file 'Dbfs.dbf' will not be included in the Dbfs.dbf file.
  467. *-- WARNING===> : If your application includes a file with the name of
  468. *--               'Dbfs.dbf', it will be overwritten with the file created
  469. *--                by this procedure.
  470. *-- Written for.: dBASE IV, 1.1
  471. *-- Rev. History: 01/31/1992 -- Original
  472. *-- Calls.......: None
  473. *-- Called by...: Any
  474. *-- Usage.......: do ListDBFs
  475. *-- Example.....: do ListDBFs
  476. *-- Returns.....: None
  477. *-- Parameters..: None
  478. *-------------------------------------------------------------------------------
  479.  
  480.    private cConsole
  481.    *-- Write the directory of dbf files to a text file (Dbfs.txt)
  482.    *-- First, erase the file if it exists
  483.    if file("Dbfs.txt")
  484.      erase dbfs.txt
  485.    endif
  486.  
  487.    *-- And, erase the dbfs.dbf file if it exists (so won't be included
  488.    *-- in the list)
  489.    if file("Dbfs.dbf")
  490.      erase Dbfs.dbf
  491.    endif
  492.  
  493.    *-- Now, write the dbfs.txt file
  494.    cConsole = set("CONSOLE")
  495.    set console off
  496.    list files to file dbfs.txt
  497.    set console &cConsole.
  498.  
  499.    *-- Then, create the file DBFS.DBF
  500.     *-- Acknowledgement..: Bowen Moursund for the code that creates Dbfs.dbf
  501.     *--                    (Download PRGCREAT.ZIP from BORBBS for more info.)
  502.    set printer to file DBFS.DBF
  503.    set printer on
  504.    ??? "{3}{92}{2}{1}{0}{0}{0}{0}{65}{0}{13}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  505.    "{0}{0}{0}{0}{0}{0}{0}{0}{89}{0}{68}{66}{70}{0}{0}{0}{0}{0}{0}{0}{0}{67}{3}"+;
  506.    "{0}{44}{85}{12}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{13}{26}"
  507.    set printer to
  508.    set printer off
  509.  
  510.    *-- Now, append dbfs.txt to dbfs.dbf if the record is a dbf listing.
  511.    use Dbfs
  512.    append from Dbfs.txt for ".DBF" $ Dbf type sdf
  513.  
  514.    use    && can remove this command if you want
  515.  
  516.    erase Dbfs.txt            && don't need it anymore
  517.  
  518. RETURN
  519. *--EOP: ListDBFs
  520.  
  521. FUNCTION Recompile
  522. *-------------------------------------------------------------------------------
  523. *-- Programmer..: Jay Parsons (CIS: 71600,340)
  524. *--             : Adapted from Compall.prg and Compall2.prg, by James Thomas.
  525. *-- Date........: 06/10/1992
  526. *-- Notes.......: Recompiles all dBASE source-code files.  Takes three
  527. *--             : optional parameters:
  528. *--             :    Directory to recompile.  Default is current directory.
  529. *--             :    Skeleton to recompile.  Default is all of .PRG, .LBG,
  530. *--             :       .FRG, .PRS, .FMT, .QBE and .UPD files.  If a skeleton
  531. *--             :       is provided that matches files that are not dBASE
  532. *--             :       source-code files, compiler errors will occur and,
  533. *--             :       in the absence of external error handling, see below,
  534. *--             :       suspend processing.
  535. *--             :    "Runtime" or any characters starting with "R" or "r" to
  536. *--             :       direct the compilation be with the "RUNTIME" option.
  537. *--             : Does not recompile a file if a file of the same root name,
  538. *--             : an .??O extension and a later timestamp resides in the
  539. *--             : directory.
  540. *--             : Renames compilations of FMT, FRG, LBG and QBO files to ??O.
  541. *--             : Returns .T. if successful, or .F.
  542. *--             :
  543. *--             : Listing of compilation errors requires SET ALTERNATE TO,
  544. *--             : and trapping such errors as passing the name of a file
  545. *--             : that does not contain dBASE source code to the COMPILE
  546. *--             : command requires an ON ERROR trap.  These are omitted here
  547. *--             : due to lack of ways to prevent the function from changing
  548. *--             : these settings externally.  Lines needed to have any
  549. *--             : compilation errors print to the alternate file are included
  550. *--             : as comments.
  551. *--             :
  552. *-- Written for.: dBASE IV Version 1.5.
  553. *--             : Adaptation to a prior release may require changing the
  554. *--             : way parameters are handled, and also rewriting the lines
  555. *--             : that use fdate() and ftime() to read timestamps.
  556. *-- Rev. History: 04/07/1992 - original function.
  557. *--             : 04/13/1992 - additional environment settings.
  558. *--             : 04/16/1992 - aliases added thanks to BOWEN.
  559. *--             : 06/10/1992 - a few minor bug fixes
  560. *-- Calls       : Makestru()            FUNCTION in FILES.PRG
  561. *-- Called by...: Any
  562. *-- Usage.......: Recompile ( [<cDir>] [,<cSkel> [,"R"]] )
  563. *-- Example.....: ? Recompile ( "\dBASE\Myprogs", "*.??G" )
  564. *-- Parameters..: cDir, a DOS directory name ( and path if needed )
  565. *--             : cSkel, skeleton using wildcards for files to compile
  566. *--             : cRun, "R" or "r" if compilation is for Runtime
  567. *-- Side effects: Creates compiled .??O files, overwriting any of the same
  568. *--             : root names that may exist.
  569. *-------------------------------------------------------------------------------
  570.  
  571.    parameters cDirectry, cSkeleton, cRun
  572.    private cCons, cAlias, cAlt, cDir, cSafety, cTempfile,;
  573.        cSrcfile, cObjfile, cString1, cString2, cRunopt
  574.  
  575.    * preserve environment
  576.    cCons = set( "CONSOLE" )
  577.    SET CONSOLE OFF
  578.    cAlias = alias()
  579.    cAlt = set( "ALTERNATE" )
  580.    SET ALTERNATE OFF
  581.    cDir = set( "DIRECTORY" )
  582.    IF type( "cDirectry" ) = "C" .AND. "" # cDirectry
  583.       SET DIRECTORY TO &cDirectry
  584.    ENDIF
  585.    cSafety = set( "SAFETY" )
  586.    SET SAFETY OFF
  587.    SELECT select()
  588.  
  589.    * make temporary structure file and fill in the DOS DIR listing structure
  590.    cTempfile = Makestru()
  591.    USE ( cTempfile ) ALIAS cTempfile
  592.    APPEND BLANK
  593.    REPLACE FIELD_NAME WITH "FILENAME", FIELD_TYPE WITH "C", FIELD_LEN WITH 9, ;
  594.        FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  595.    APPEND BLANK
  596.    REPLACE FIELD_NAME WITH "EXT", FIELD_TYPE WITH "C", FIELD_LEN WITH 4, ;
  597.        FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  598.    APPEND BLANK
  599.    REPLACE FIELD_NAME WITH "FLENGTH", FIELD_TYPE WITH "C", FIELD_LEN WITH 10, ;
  600.        FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  601.    APPEND BLANK
  602.    REPLACE FIELD_NAME WITH "TIMESTAMP", FIELD_TYPE WITH "C", FIELD_LEN WITH 16, ;
  603.        FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  604.  
  605.    * make .dbf for source file names, reset and return if error occurs
  606.    cSrcfile = cTempfile
  607.    DO WHILE file ( cSrcfile + ".DBF" )
  608.       cSrcfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  609.    ENDDO
  610.    CREATE ( cSrcfile ) FROM  ( cTempfile )
  611.    USE ( cSrcfile ) alias cSrcfile
  612.  
  613.    IF "" = alias()
  614.      ERASE ( cTempfile +".DBF" )
  615.      SET DIRECTORY TO &cDir
  616.      SET ALTERNATE &cAlt
  617.      IF "" # cAlias
  618.     SELECT ( cAlias )
  619.      ENDIF
  620.      SET CONSOLE &cCons
  621.      RETURN .F.
  622.    ENDIF
  623.  
  624.    * and for object file names
  625.    SELECT select()
  626.    USE ( cTempfile ) ALIAS cTempfile
  627.    GO 1
  628.    REPLACE FIELD_IDX WITH "Y"
  629.    cObjfile = cSrcfile
  630.    DO WHILE file ( cObjfile + ".DBF"  )
  631.       cObjfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  632.    ENDDO
  633.    CREATE ( cObjfile ) FROM (cTempfile)
  634.    use ( cObjfile ) alias cObjfile order filename
  635.    IF "" = alias()
  636.       ERASE ( cTempfile + ".DBF" )
  637.       SELECT cSrcfile
  638.       USE
  639.       ERASE ( cSrcfile + ".DBF" )
  640.       SET DIRECTORY TO &cDir
  641.       SET ALTERNATE &cAlt
  642.       IF "" # cAlias
  643.      SELECT  ( cAlias )
  644.       ENDIF
  645.       SET CONSOLE &cCons
  646.       RETURN .F.
  647.    ENDIF
  648.  
  649.    * reuse name of cTempfile as SDF; DIR names of source files to it and append
  650.    cString1 = cTempfile + ".DBF"
  651.  
  652.    RUN dir *.* > &cString1
  653.    SELECT  cSrcfile
  654.    APPEND FROM ( cString1 ) TYPE SDF
  655.  
  656.    * delete directory entries not for source files of desired name or type
  657.    IF type("cSkeleton") = "C" .AND. "" # cSkeleton
  658.       DELETE ALL FOR .NOT. like( upper( cSkeleton ), trim( Filename ) +"." ;
  659.         + trim( Ext ) )
  660.    ELSE
  661.       DELETE ALL FOR .NOT. Ext $ "PRG LBG FRG PRS FMT QBE UPD "
  662.    ENDIF
  663.    PACK
  664.  
  665.    * reuse again for .??O files
  666.    RUN dir *.??o > &cString1
  667.    SELECT cObjfile
  668.    APPEND FROM ( cString1 ) TYPE SDF
  669.    DELETE ALL FOR left( Filename, 1 ) = " " .OR. right( Ext, 2 ) # "O "
  670.    PACK
  671.    ERASE ( cString1 )
  672.  
  673.    * assemble Runtime option
  674.    cRunopt = iif( type( "cRun" ) = "C" .AND. "" # cRun ;
  675.        .AND. left( cRun, 1 ) $ "Rr", " RUNTIME", "" )
  676.  
  677.    * now compile all the files that need it
  678.    SELECT cSrcfile
  679.    SCAN
  680.       cString1 = trim( Filename ) + "." + trim( Ext )
  681.       *   Is there an object file of this name?
  682.       IF Seek( Filename, "cObjfile" )
  683.      cString2 = trim( cObjfile->Filename ) + "." + trim( cObjfile->Ext )
  684.      cString2 = dtos( fdate( cString2 ) ) + ftime( cString2 )
  685.      *   then check timestamps and skip it if already compiled
  686.      IF dtos( fdate( cString1 ) ) + ftime( cString1 ) < cString2
  687.         LOOP
  688.      ENDIF
  689.       ENDIF
  690.       *   compile it otherwise, listing errors if enabled
  691.       cString2 = cString1 + cRunopt
  692.       * SET ALTERNATE ON
  693.       * ? "Compiling " + cString2
  694.       COMPILE &cString2
  695.       * ?
  696.       * SET ALTERNATE OFF
  697.       *   and rename object files that should not be .DBOs
  698.       IF Ext $ "FMT FRG LBG QBE "
  699.      cString2 = stuff( cString1, len( cString1 ), 1, "O" )
  700.      IF file( cString2 )
  701.         ERASE ( cString2 )
  702.      ENDIF
  703.      cString1 = trim( Filename ) + ".DBO"
  704.      RENAME ( cString1 ) TO ( cString2 )
  705.       ENDIF
  706.    ENDSCAN
  707.  
  708.    *  Clean up
  709.    USE
  710.    ERASE ( cSrcfile + ".DBF" )
  711.    SELECT cObjfile
  712.    USE
  713.    ERASE ( cObjfile + ".DBF" )
  714.    ERASE ( cObjfile + ".MDX" )
  715.    SET SAFETY &cSafety
  716.    SET DIRECTORY TO &cDir
  717.    SET ALTERNATE &cAlt
  718.    IF "" # cAlias
  719.      SELECT ( cAlias )
  720.    ENDIF
  721.    SET CONSOLE &cCons
  722.  
  723. RETURN .T.
  724. *-- Eof() Recompile
  725.  
  726. PROCEDURE Makedbf
  727. *-------------------------------------------------------------------------------
  728. *-- Programmer..: Jay Parsons (CIS: 71600,340).
  729. *-- Date........: 04/26/1992
  730. *-- Notes.......: Makes an empty dBASE .dbf file
  731. *-- Written for.: dBASE IV, 1.1, 1.5
  732. *-- Rev. History: 04/26/1992 -- Original
  733. *-- Calls.......: Tempname()          function in FILES.PRG
  734. *-- Called by...: Any
  735. *-- Usage.......: DO MakeDbf WITH <cFilename>, <cStrufile>, <cArray>
  736. *-- Example.....: DO MakeDbf WITH Customers, cCustfields
  737. *-- Parameters..: cFilename - filename ( without extension ) of the .dbf to be
  738. *--               created.
  739. *--               cStrufile - name ( without extension ) of a STRUC EXTE .dbf
  740. *--               cArray - name of the array holding field information for the
  741. *--               .dbf.  The array must be dimensioned [ F, 5 ] where F is the
  742. *--               number of fields.  Each row must hold data for one field:
  743. *--                     [ F, 1 ]  field name, character
  744. *--                     [ F, 2 ]  field type, character from set "CDFLMN"
  745. *--                     [ F, 3 ]  field length, numeric.  If field type is
  746. *--                                 D, L, or M, will be ignored
  747. *--                     [ F, 4 ]  field decimals, numeric. optional if 0.
  748. *--                     [ F, 5 ]  field is mdx tag, char $ "YN", optional if N
  749. *-------------------------------------------------------------------------------
  750.   parameters cFname, cSname, aAname
  751.   private nX,cF1,cF2,cF3,cF4,cF5,cStrufile,cFtype
  752.   cF1 = aAname + "[nX,1]"
  753.   cF2 = aAname + "[nX,2]"
  754.   cF3 = aAname + "[nX,3]"
  755.   cF4 = aAname + "[nX,4]"
  756.   cF5 = aAname + "[nX,5]"
  757.   select select()
  758.   use ( cSname ) ALIAS cSname
  759.   zap
  760.   nX = 1
  761.   do while type( cF1 ) # "U"
  762.     cFtype = &cF2
  763.     append blank
  764.     replace Field_name with &cF1, Field_type with cFtype
  765.     do case
  766.       case cFtype = "D"
  767.     replace Field_len with 8
  768.       case cFtype = "M"
  769.     replace Field_len with 10
  770.       case cFtype = "L"
  771.     replace Field_len with 1
  772.       otherwise
  773.     replace Field_len with &cF3
  774.     endcase
  775.     if type( cF4 ) = "N" .and. cFtype $ "FN"
  776.     replace Field_dec with &cF4
  777.     else
  778.     replace Field_dec with 0
  779.     endif
  780.     if type( cF5 ) # "U" .and. cFtype $ "CDFN" .and. &cF5 = "Y"
  781.       replace Field_idx with "Y"
  782.     else
  783.       replace Field_idx with "N"
  784.     endif
  785.     nX = nX + 1
  786.   enddo
  787.   use
  788.   create ( cFname ) FROM ( cSname )
  789.  
  790. RETURN
  791. *-- EoP: Makedbf
  792.  
  793. PROCEDURE MakeDBF2
  794. *-------------------------------------------------------------------------------
  795. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  796. *-- Date........: 02/22/1993
  797. *-- Notes.......: Creates an empty DBF file of the structure specified in
  798. *--               the array aMakeDBF[], which must be declared and initialized
  799. *--               with the proper values before calling this procedure.
  800. *--               The array must be declared as aMakeDBF[n,5], where n is
  801. *--               the number of fields in the DBF to be created. The columns
  802. *--               of the array correspond to the fields of a structure extended
  803. *--               file, and must be initialized to the appropriate values,
  804. *--               before calling this procedure, one row for each field.
  805. *--
  806. *--               Structure of a structure extended file:
  807. *--               Field    Type  Len  Dec
  808. *--               -----------------------
  809. *--               FIELD_NAME  C   10    0
  810. *--               FIELD_TYPE  C    1    0
  811. *--               FIELD_LEN   N    3    0
  812. *--               FIELD_DEC   N    3    0
  813. *--               FIELD_IDX   C    1    0
  814. *--
  815. *--               aMakeDBF[n,1] = Field name: 10 or less characters
  816. *--               aMakeDBF[n,2] = Field type: 1 character
  817. *--                               "C" = character
  818. *--                               "N" = numeric
  819. *--                               "F" = float
  820. *--                               "D" = date
  821. *--                               "L" = logical
  822. *--                               "M" = memo
  823. *--               aMakeDBF[n,3] = Field length: numeric
  824. *--                               "C" = 1 - 254
  825. *--                               "N","F" = use dBASE guidelines
  826. *--                               "D" = 8
  827. *--                               "L" = 1
  828. *--                               "M" = 10
  829. *--               aMakeDBF[n,4] = Decimal places: numeric
  830. *--                               0 for non numeric fields
  831. *--               aMakeDBF[n,5] = MDX flag: 1 char, "Y" or "N"
  832. *--
  833. *-- Written for.: dBASE IV, 1.5
  834. *-- Rev. History: 05/27/1992 -- Original Release
  835. *--               02/22/1993 -- Minor changes to PRIVATE calls.
  836. *-- Calls.......: None
  837. *-- Called by...: Any
  838. *-- Usage.......: do MakeDBF with <cDBFpath>,<cStruPath>
  839. *-- Example.....: cStruPath = MakeStru2(.f.)
  840. *--               declare aMakeDBF[1,5]
  841. *--               aMakeDBF[1,1] = "FIELD1"
  842. *--               aMakeDBF[1,2] = "C"
  843. *--               aMakeDBF[1,3] = 20
  844. *--               aMakeDBF[1,4] = 0
  845. *--               aMakeDBF[1,5] = "N"
  846. *--               do MakeDBF2 with "foo", cStruPath
  847. *--               erase (cStruPath+".dbf")
  848. *--               release aMakeDBF
  849. *-- Returns.....: none
  850. *-- Parameters..: cDBFpath = the [path]filename of the DBF to be created.
  851. *--               cStruPath = the [path]filename of an empty structure extended
  852. *--                           file.
  853. *-------------------------------------------------------------------------------
  854.  
  855.    parameters cDBFpath,cStruPath
  856.    if pcount() = 2  && we need 2 parms
  857.       private cAlias
  858.       if type("aMakeDBF[1,1]") = "C"  && check array validity
  859.      cAlias = alias()
  860.      select select()
  861.      use (cStruPath)
  862.      append from array aMakeDBF
  863.      use
  864.      create (cDBFpath) from (cStruPath)
  865.      use
  866.      if "" # cAlias
  867.         select (cAlias)
  868.      endif
  869.       endif
  870.    endif
  871.  
  872. RETURN
  873. *-- EoP: MakeDBF2
  874.  
  875. FUNCTION Makestru
  876. *-------------------------------------------------------------------------------
  877. *-- Programmer..: Martin Leon (Hman), formerly sysop of A-T BBS
  878. *--             : Revised by Jay Parsons, (CIS: 71600,340).
  879. *-- Date........: 04/24/1992
  880. *-- Notes.......: Makes an empty dBASE STRUCTURE EXTENDED file and returns
  881. *--             : its root name
  882. *-- Written for.: dBASE IV v1.5
  883. *-- Rev. History: 06/12/1991 - original function.
  884. *--             : Changed to take no parameter, return filename, 4-7-1992.
  885. *--             : Code added to preserve catalog status and name, 4-10-1992.
  886. *--             : Use of Tempname() added 4-24-92.
  887. *--             : set("safety") check, minor mods, 05-28-1992, Bowen Moursund
  888. *-- Calls       : Tempname()          Function in FILES.PRG
  889. *-- Called by...: Any
  890. *-- Usage.......: Makestru()
  891. *-- Example.....: Tempfile = Makestru()
  892. *-- Returns.....: Name of file created
  893. *-- Parameters..: None
  894. *-------------------------------------------------------------------------------
  895.  
  896.    private all
  897.    lTitleOn = ( set("TITLE") = "ON" )
  898.    lSafeOn = ( set("SAFETY") = "ON" )
  899.    lCatOff = ( set("CATALOG") = "OFF" )
  900.    cAlias = alias()
  901.    cTmpCat = TempName("cat") + ".CAT"
  902.    set title off
  903.    set safety off
  904.    cCatalog = catalog()
  905.    set catalog to (cTmpCat)
  906.    set catalog to &cCatalog.
  907.    cStruName = TempName("dbf")
  908.    select select()
  909.    use (cTmpCat) nosave
  910.    copy to (cStruName) structure extended
  911.    use (cStruName) exclusive
  912.    zap
  913.    use
  914.    if lTitleOn
  915.       set title on
  916.    endif
  917.    if lSafeOn
  918.       set safety on
  919.    endif
  920.    if lCatOff
  921.       set catalog off
  922.    endif
  923.    if "" # cAlias
  924.       select (cAlias)
  925.    endif
  926.     
  927. RETURN cStruname
  928. *-- Eof: Makestru()
  929.  
  930. FUNCTION MakeStru2
  931. *-------------------------------------------------------------------------------
  932. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  933. *-- Date........: 05/27/1992
  934. *-- Notes.......: Create an empty STRUCTURE EXTENDED file, using DBASE print
  935. *--               redirection. If specified, the file will be created in the
  936. *--               subdirectory pointed to by the DOS environment variable
  937. *--               DBTMP, if it is set, otherwise in the current subdirectory.
  938. *--
  939. *--               Structure of a STRUCTURE EXTENDED file:
  940. *--               Field    Type  Len  Dec
  941. *--               -----------------------
  942. *--               FIELD_NAME  C   10    0
  943. *--               FIELD_TYPE  C    1    0
  944. *--               FIELD_LEN   N    3    0
  945. *--               FIELD_DEC   N    3    0
  946. *--               FIELD_IDX   C    1    0
  947. *--
  948. *-- Written for.: dBASE IV v1.1
  949. *-- Rev. History: 05/27/1992 -- Original
  950. *-- Calls.......: TEMPNAME()           Function in FILES.PRG
  951. *-- Called by...: Any, except when printing
  952. *-- Usage.......: MakeStru(<lDBTMP>)
  953. *-- Example.....: cStruPath = MakeStru2(.T.)
  954. *-- Returns.....: The name, no extension, of the file created.
  955. *-- Parameters..: lDBTMP = create the file in the DBTMP subdirectory, or not.
  956. *-- Side Effects: WARNING: Do not call when printing.
  957. *-------------------------------------------------------------------------------
  958.  
  959.    parameter lDBTMP
  960.    private all
  961.    cDBTMP = ""  && TempName() will assign this, if lDBTMP
  962.    if lDBTMP
  963.       cFname = TempName( "dbf", .t. )
  964.    else
  965.       cFname = TempName( "dbf", .f. )
  966.    endif
  967.    cPath = iif( "" # cDBTMP, cDBTMP, set("DIRECTORY") ) + "\" + cFname + ".DBF"
  968.    dDate = date()
  969.    set printer to file (cPath)
  970.    set printer on
  971.    * Thanks to JPARSONS for the suggestion to document the header structure
  972.    ??? "{3}"           && various bit flags
  973.    ??? chr(year(dDate)-1900) + chr(month(dDate)) + ;
  974.        chr(day(dDate)) && date bytes in YYMMDD format
  975.    ??? "{0}{0}{0}{0}"  && no. of records
  976.    ??? "{193}{0}"      && no. of bytes in header
  977.    ??? "{19}{0}"       && no. of bytes per record
  978.    ??? "{0}{0}"        && reserved
  979.    ??? "{0}"           && incomplete transaction flag
  980.    ??? "{0}"           && encryption flag
  981.    ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}" + ;
  982.        "{0}{0}{0}"     && multi-user reserved
  983.    ??? "{0}"           && MDX flag
  984.    ??? "{0}{0}{0}"     && reserved
  985.    * field descriptors
  986.    ??? "{70}{73}{69}{76}{68}{95}{78}{65}{77}{69}{0}{67}{3}{0}{208}" + ;
  987.        "{72}{10}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"  && Field_Name
  988.    ??? "{70}{73}{69}{76}{68}{95}{84}{89}{80}{69}{0}{67}{13}{0}{208}" + ;
  989.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Type
  990.    ??? "{70}{73}{69}{76}{68}{95}{76}{69}{78}{0}{0}{78}{14}{0}{208}" + ;
  991.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Len
  992.    ??? "{70}{73}{69}{76}{68}{95}{68}{69}{67}{0}{0}{78}{17}{0}{208}" + ;
  993.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Dec
  994.    ??? "{70}{73}{69}{76}{68}{95}{73}{68}{88}{0}{0}{67}{20}{0}{208}" + ;
  995.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Idx
  996.    ??? "{13}{26}"
  997.    set printer to
  998.    set printer off
  999.  
  1000. RETURN cFname
  1001. *-- Eof() MakeStru2
  1002.  
  1003. FUNCTION TempName
  1004. *-------------------------------------------------------------------------------
  1005. *-- Programmer..: Martin Leon (HMAN)  Former Sysop, ATBBS
  1006. *-- Date........: 02/22/1993
  1007. *-- Notes.......: Obtain a name for a temporary file of a given extension
  1008. *--               that does not conflict with existing files.
  1009. *-- Written for.: dBASE IV, v1.5
  1010. *-- Rev. History: Originally part of Makestru(), 6-12-1991
  1011. *--               04/26/92, made a separate function - Jay Parsons
  1012. *--               05/27/92, added lDBTMP option - Bowen Moursund
  1013. *--               02/22/93, Minor update to PRIVATE command.
  1014. *-- Calls.......: None
  1015. *-- Called by...: Any
  1016. *-- Usage.......: TempName( cExt , lDBTMP )
  1017. *-- Example.....: Sortfile = TempName( "DBF" , .t. )
  1018. *-- Returns.....: Name not already in use. Additionally, if the memvar
  1019. *--               cDBTMP is declared before calling the function with
  1020. *--               the lDBTMP option, it will be assigned the result
  1021. *--               of getenv("DBTMP").
  1022. *-- Parameters..: cExt   = Extension to be given file ( without the "." )
  1023. *--               lDBTMP = Optional. If .t., function returns unique file
  1024. *--                        name in the DBTMP subdirectory.
  1025. *-- Side Effects: The function will return a unique filename for the DEFAULT
  1026. *--               subdirectory if the lDBTMP option is used and the DOS
  1027. *--               environment variable DBTMP does not point to a valid
  1028. *--               subdirectory.
  1029. *-------------------------------------------------------------------------------
  1030.  
  1031.    parameters cExt, lDBTMP
  1032.    private cDefDir
  1033.    cDefDir = set("DIRECTORY")
  1034.    if lDBTMP
  1035.       cDBTMP = getenv("DBTMP")
  1036.       if "" # cDBTMP
  1037.      set directory to &cDBTMP.
  1038.       endif
  1039.    endif
  1040.    do while .t.
  1041.       Fname = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  1042.       if .not. file( Fname + "." + cExt ) .and. ( upper( cExt ) # "DBF" .or.;
  1043.      .not. ( file( Fname + ".MDX" ) .or. file ( Fname + ".DBT" ) ) )
  1044.         exit
  1045.       endif
  1046.    enddo
  1047.    set directory to &cDefDir.
  1048.  
  1049. RETURN Fname
  1050. *-- Eof() TempName
  1051.  
  1052. PROCEDURE FileMove
  1053. *-------------------------------------------------------------------------------
  1054. *-- Programmer..: David Frankenbach (FRNKNBCH)
  1055. *--               DF Software Development, Inc.
  1056. *--               PO Box 87
  1057. *--               Forest, VA, 24551
  1058. *--               (804) 237-2342
  1059. *-- Date........: 02/11/1992
  1060. *-- Notes.......: This procedure gives the record movement allowed with EDIT
  1061. *--               when you use a simple @SAY/GET..READ. It allows you to
  1062. *--               pre/post process each record during editing, something you
  1063. *--               can't do with EDIT. This works best with a single file,
  1064. *--               although it would work with a parent->child relation. You
  1065. *--               should:  SELECT child and SET SKIP to child. This will
  1066. *--               allow the user to change the parent record pointer though!
  1067. *--               If you want to limit the child record movement to a single
  1068. *--               parent record, you can use a conditional index, or add logic
  1069. *--               to the routine to limit the record pointer movement. For these
  1070. *--               cases I have a seperate FileMove procedure, but they are not
  1071. *--               generic enough for public consumption.
  1072. *--
  1073. *--               These keys are trapped:
  1074. *--               UpArw, Shift-Tab, LeftArw, Ctrl-LeftArw, PgUp = 
  1075. *--                                                         backward one record
  1076. *--               DnArw, Tab, RightArw, Ctrl-RightArw, PgDn, Enter, Ctrl-End = 
  1077. *--                                                         forward one record
  1078. *--               Ctrl-PgUp = top of database or active index
  1079. *--               Ctrl-PgDn = bottom of database or active index
  1080. *-- Written for.: dBASE IV, 1.1
  1081. *-- Rev. History: 06/17/1991 - original routine.
  1082. *--               02/07/1992 -- Ken Mayer, brought into one PROCEDURE,
  1083. *--               rather than a function and a procedure ...
  1084. *--               02/11/1992 -- Author, additional documentation
  1085. *--                             Released into Public Domain
  1086. *-- Calls.......: None
  1087. *-- Called by...: None
  1088. *-- Usage.......: do FileMove with <nKey>
  1089. *--               where: <nKey> is the return value of readkey()
  1090. *-- Example.....: lMove = .t.  && if you want the user to be able to move the 
  1091. *--                            && record pointer in my applications if the user
  1092. *--                            && is adding a new record I usually lMove = .f.,
  1093. *--                            && for editing I allow them to move through the
  1094. *--                            && records.
  1095. *--               lOk = .t.
  1096. *--               do while ( lOk )
  1097. *--                  do Mem_Load               && load memvars from record
  1098. *--                  @say/gets                 && display/get the memvars
  1099. *--                  read
  1100. *--                  i = readkey()             && grab last key ...
  1101. *--                  lOk = ( i <> 27 )         && if Esc was pressed lOK is false
  1102. *--                  if ( lOk )
  1103. *--                     if ( i > 256 )         && if record is changed
  1104. *--                        do Mem_Unload       && replace dbf fields from memvars
  1105. *--                     endif  && ( i > 256 )
  1106. *--                     if ( lMove )           && if ok to move record pointer
  1107. *--                        do FileMove with i  && <----- Move it
  1108. *--                     else
  1109. *--                        lOk = .f.            && terminate loop if .not. lMove
  1110. *--                     endif  && ( lMove )
  1111. *--                  endif && (lOK)
  1112. *--               enddo && while (lOK)
  1113. *-- Parameters..: nKey = last keystroke from a READKEY() call ...
  1114. *-- Returns.....: None
  1115. *-- Side Effects: Moves record pointer in current file if lMove = .t.
  1116. *-------------------------------------------------------------------------------
  1117.     parameter nKey
  1118.     private n
  1119.     
  1120.     m->n = m->nKey
  1121.     if ( m->n > 255 )     && if value is > 256, record has changed, but we want
  1122.        m->n = m->n - 256  && values < 256 to figure out which direction to move
  1123.     endif                 && from the readkey() table
  1124.     
  1125.     do case
  1126.     
  1127.        *-- keys to move backward through database 1 record at a time ...
  1128.        *--  LeftArw, Ctrl-LeftArw, UpArw, Shift-Tab, PgUp
  1129.        case ( m->n = 0 ) .or. ( m->n = 2 ) .or. ( m->n = 4 ) .or. ( m->n = 6 )
  1130.           if ( .not. bof() )                && if not at beginning of file
  1131.          skip -1                        && move backward one record
  1132.           endif
  1133.     
  1134.        *-- keys to move forward through database 1 record at a time ...
  1135.        *--  RightArw, Ctrl-RightArw, DownArw, Tab, PgDn, Ctrl-End, Enter
  1136.        case ( m->n = 1 ) .or. ( m->n = 3 ) .or. ( m->n = 5 ) .or. ( m->n = 7 );
  1137.              .or. ( m->n = 14) .or. ( m->n = 15)
  1138.           if ( .not. eof() )                && if not end of file
  1139.          skip 1                         && move forward one record
  1140.           endif
  1141.           if ( eof() )                      && if we're now at the EOF,
  1142.          goto bottom                    && go back to last record ...
  1143.           endif
  1144.     
  1145.        *-- go to toP of database, Ctrl-PgUp
  1146.        case ( m->n = 34 )
  1147.           goto top
  1148.     
  1149.        *-- go to BOTtoM of database, Ctrl-PgDn
  1150.        case ( m->n = 35 )
  1151.           goto bottom
  1152.     
  1153.     endcase
  1154.  
  1155. RETURN
  1156. *-- EoP: FileMove
  1157.  
  1158. FUNCTION Used
  1159. *-------------------------------------------------------------------------------
  1160. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1161. *-- Date........: 02/28/1992
  1162. *-- Notes.......: Created because the picklist routine by Malcolm Rubel
  1163. *--               from DBA Magazine (11/91) calls a function that checks
  1164. *--               to see if a DBF file is open ... 
  1165. *-- Written for.: dBASE IV, 1.5
  1166. *-- Rev. History: 05/15/1992 -- Original
  1167. *--               02/08/1993 -- Discovered (thanks to Jay, and then Malcolm)
  1168. *--               a much simpler way to do this ...
  1169. *-- Called by...: Any
  1170. *-- Calls.......: None
  1171. *-- Usage.......: Used("<cFile>")
  1172. *-- Example.....: if used("Library")
  1173. *--                  select library
  1174. *--               else
  1175. *--                  select select()
  1176. *--                  use library
  1177. *--               endif
  1178. *-- Returns.....: Logical (.t. if file is in use, .f. if not)
  1179. *-- Parameters..: cFile = file to check for
  1180. *-------------------------------------------------------------------------------
  1181.     
  1182.     parameters cFile
  1183.     
  1184. RETURN (select(cFile) # 0)
  1185. *-- EoF: Used()
  1186.  
  1187. FUNCTION MDXbyte
  1188. *-------------------------------------------------------------------------------
  1189. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1190. *-- Date........: 05/21/1992
  1191. *-- Notes.......: Sets the MDX byte in a DBF header ON or OFF.
  1192. *--               The DBF must not be open when the function is called.
  1193. *-- Written for.: dBASE IV v1.5
  1194. *-- Rev. History: 05/21/1992 -- Original
  1195. *-- Calls.......: dBASE low level file functions
  1196. *-- Called by...: Any
  1197. *-- Usage.......: MDXbyte(<cDBFpath>,<cOnOff>)
  1198. *-- Example.....: lByteSet = MDXbyte("mydbf.dbf","OFF")
  1199. *-- Returns.....: .T. if successful
  1200. *-- Parameters..: cDBFpath = the [path]filename.ext of the DBF
  1201. *--               cOnOff   = "ON" or "OFF"
  1202. *-------------------------------------------------------------------------------
  1203.  
  1204.    parameters cDBFpath,cOnOff
  1205.    private all
  1206.    cOnOff = upper(cOnOff)
  1207.    * check the validity of the parameters
  1208.    lSuccess = ( pcount() = 2 .AND. cOnOff $ "ON|OFF" .AND. file(cDBFpath) )
  1209.    if lSuccess
  1210.       nHandle = fopen(cDBFpath,"RW")
  1211.       if nHandle > 0
  1212.      if fseek(nHandle, 28) = 28
  1213.         lSuccess = ( fwrite(nHandle, iif(cOnOff="OFF",chr(0),chr(1))) = 1 )
  1214.      else
  1215.         lSuccess = .F.
  1216.      endif
  1217.      lClosed = fclose(nHandle)
  1218.       else
  1219.      lSuccess = .F.
  1220.       endif
  1221.    endif
  1222.  
  1223. RETURN lSuccess
  1224. *-- Eof() MDXbyte
  1225.  
  1226. FUNCTION aDir
  1227. *-------------------------------------------------------------------------------
  1228. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1229. *-- Date........: 02/22/1993
  1230. *-- Notes.......: aDir() creates a public array gaDir[ n, 5 ] containing
  1231. *--               directory information. gaDir[ n, 5 ] is limited to 234
  1232. *--               rows (files) or less, depending on the memory available.
  1233. *--
  1234. *--                     Structure of 2D array gaDir[ n, 5 ]:
  1235. *--
  1236. *--                     Col  Contents             Type       Width
  1237. *--                     ------------------------------------------
  1238. *--                       1  File Name            Character     12
  1239. *--                       2  Date (mm/dd/yy)      Date           8
  1240. *--                       3  Time (hh:mm:ss)      Character      8
  1241. *--                       4  Size (bytes)         Numeric       10
  1242. *--                       5  Attributes           Character      6
  1243. *--
  1244. *--               aDir() makes use of SEARCH.BIN, and credit is due its
  1245. *--               author (Roland Boucherau, Borland Technical Support). 
  1246. *--               See SEARCH.ASM or SEARCH.TXT source for details.
  1247. *--               *****************************
  1248. *--               **** REQUIRES SEARCH.BIN ****
  1249. *--               *****************************
  1250. *-- Written for.: dBASE IV, v1.5
  1251. *-- Rev. History: 07/24/1992 -- Original Release
  1252. *--               02/22/1993 -- Minor Update to PRIVATE call.
  1253. *-- Calls.......: None
  1254. *-- Called by...: Any
  1255. *-- Usage.......: adir( <cFMask>, <cBINpath>, <cAttr> )
  1256. *-- Examples....: nFiles = adir( "d:\app\fu*.db?", "d:\dbase4\library\", "" )
  1257. *--               nFiles = adir( cPathSkel )
  1258. *--               nFiles = adir( "c:\*.*", "", "RHSD" )
  1259. *-- Returns.....: Number of matching files found: rows in gaDir[]
  1260. *-- Parameters..: cPathSkel = the directory path and file skeleton that you
  1261. *--                           want, like the DOS DIR command. Wildcards OK.
  1262. *--               cBINpath = Optional path to Search.Bin. If omitted,
  1263. *--                          Search.Bin must be in current subdirectory.
  1264. *--                          Include the trailing backslash.
  1265. *--               cAttr = Optional file attribute mask string.
  1266. *--
  1267. *--                             Mask Codes
  1268. *--                            ------------
  1269. *--                            R - Read Only
  1270. *--                            H - Hidden
  1271. *--                            S - System
  1272. *--                            D - Directory
  1273. *--                            V - Volume
  1274. *--                            A - Archive
  1275. *--
  1276. *--                       If cAttr is omitted, null, or blank, gaDir[] will
  1277. *--                       contain only 'ordinary' files, i.e. files without
  1278. *--                       HSDV attributes. If V is specified in the mask,
  1279. *--                       ONLY volume labels are matched. Any other attribute
  1280. *--                       or combination of attributes results in those files
  1281. *--                       AND ordinary files being matched.
  1282. *-------------------------------------------------------------------------------
  1283.  
  1284.     parameters cPathSkel, cBINpath, cAttr
  1285.     private cModule,cAttr,cFSkel,cFName,cFDate,cFTime,cFSize,cFAttr,;
  1286.             nMaxRows,nFCount,nResult,n
  1287.     cModule = iif( pcount() >= 2, cBINpath + "search.bin", "search.bin" )
  1288.     store upper( iif( pcount() >= 3, left( cAttr + "      ", 6 ), "      " ) ) ;
  1289.          to cAttr, cFAttr
  1290.     cFSkel = left( cPathSkel + space(12), max( len( cPathSkel ), 12 ) )
  1291.     cFName = cFSkel
  1292.     * ( memory() * 3.4 ) is a guess on max rows before 'Insufficient Memory'
  1293.     nMaxRows = min( memory() * 3.4, 234 )  && 234 is the absolute maximum
  1294.     nFCount = 0
  1295.     load ( cModule )
  1296.     nResult = call( "Search", 1, cFName, cAttr )
  1297.     if nResult = 0
  1298.     do while nResult = 0 .and. nFCount <= nMaxRows
  1299.         nFCount = nFCount + 1
  1300.         nResult = call( "Search" , 2, cFName )
  1301.     enddo
  1302.     nFCount = min( nMaxRows, nFCount )
  1303.     release gaDir
  1304.     public array gaDir[ nFCount, 5 ]
  1305.     cFName = cFSkel
  1306.     cFDate = "  /  /  "
  1307.     cFTime = "  :  :  "
  1308.     nFSize = 0
  1309.     n = 1
  1310.     nResult = ;
  1311.     call( "Search", 1, cFName, cFAttr, cFDate, cFTime, nFSize )
  1312.     do while nResult = 0 .AND. n <= nFCount
  1313.         store cFName to         gaDir[ n, 1 ]
  1314.         store ctod( cFDate ) to gaDir[ n, 2 ]
  1315.         store cFTime to         gaDir[ n, 3 ]
  1316.         store nFSize to         gaDir[ n, 4 ]
  1317.         store cFAttr to         gaDir[ n, 5 ]
  1318.         nResult = ;
  1319.          call( "Search", 2, cFName, cFAttr, cFDate, cFTime, nFSize )
  1320.         n = n + 1
  1321.     enddo
  1322.     else
  1323.     release gaDir
  1324.     endif
  1325.     release module Search
  1326.  
  1327. RETURN nFCount
  1328. *-- EoF: aDir()
  1329.  
  1330. FUNCTION DbfDir
  1331. *-------------------------------------------------------------------------------
  1332. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1333. *-- Date........: 07/03/1992
  1334. *-- Notes.......: DbfDir() creates or OVERWRITES DdbDir.Dbf, and populates
  1335. *--               it with directory information. The function uses the DOS
  1336. *--               5.0 DIR command and requires DOS 5.0.
  1337. *--
  1338. *--                          Structure of DBFDIR.DBF
  1339. *--                          -----------------------
  1340. *--                          Field    Type  Len  Dec
  1341. *--                          F_NAME      C   12    0
  1342. *--                          F_DATE      D    8    0
  1343. *--                          F_TIME      C    8    0
  1344. *--                          F_SIZE      N   10    0
  1345. *--               *********************************************************
  1346. *--               * DO NOT CALL THIS ROUTINE WHILE PRINTING (the function *
  1347. *--               * uses Print Redirection ...)                           *
  1348. *--               *********************************************************
  1349. *-- Written for.: dBASE IV v1.5, DOS 5.0
  1350. *-- Rev. History: 07/03/1992 -- Original
  1351. *-- Calls.......: TempName()           Function in FILES.PRG
  1352. *-- Called by...: None
  1353. *-- Usage.......: DbfDir( "<cPathSkel>", <lHidSys> )
  1354. *-- Examples....: nFiles = DbfDir( "*.dbf" )
  1355. *--               nFiles = DbfDir( "*.dbf", .t. )
  1356. *-- Returns.....: Number of matching files found: reccount() of DbfDir.dbf
  1357. *-- Parameters..: cPathSkel = the directory path and file skeleton that you
  1358. *--                           want, like the DOS DIR command. Wildcards OK.
  1359. *--               lHidSys   = Optional. If .t., hidden & system files
  1360. *--                           are included.
  1361. *-------------------------------------------------------------------------------
  1362.  
  1363.     parameters cPathSkel, lHidSys
  1364.     private all
  1365.     cDBTMP = ""
  1366.     cTmpFile = tempname( "txt", .t. ) + ".txt"
  1367.     cTmpFile = iif( "" = cDBTMP, cTmpFile, cDBTMP + "\" + cTmpFile )
  1368.     cDirParms = iif( lHidSys, "/B/A-D/ON", "/B/A-D-H-S/ON" )
  1369.     run dir &cPathSkel. &cDirParms. > &cTmpFile.
  1370.     nFiles = 0
  1371.     if fsize( cTmpFile ) > 0
  1372.     lSafeOn = ( set( "safety" ) = "ON" )
  1373.     set safety off
  1374.     set printer to file DbfDir.dbf  && create DbfDir.dbf
  1375.     set printer on
  1376.     * first byte of header - various bit flags
  1377.     ??? "{3}"
  1378.     * next 3 bytes - file date in binary YYMMDD
  1379.     ??? chr(year(date())-1900) + chr(month(date())) + chr(day(date()))
  1380.     * the rest of the header, field descriptors, and records if any
  1381.     ??? "{0}{0}{0}{0}{161}{0}{39}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  1382.     "{0}{0}{0}{0}{0}{0}{0}{1}{1}{70}{95}{78}{65}{77}{69}{0}{0}{0}{0}{0}"+;
  1383.     "{67}{0}{0}{0}{0}{12}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  1384.     "{70}{95}{68}{65}{84}{69}{0}{0}{0}{0}{0}{68}{0}{0}{0}{0}"
  1385.     ??? "{8}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{84}"+;
  1386.     "{73}{77}{69}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}{8}{0}{0}{0}{0}{0}{0}"+;
  1387.     "{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{83}{73}{90}{69}{0}{0}{0}{0}{0}"+;
  1388.     "{78}{0}{0}{0}{0}{10}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  1389.     ??? "{0}{0}{0}{13}{26}"
  1390.     set printer to
  1391.     set printer off
  1392.     cAlias = alias()
  1393.     select select()
  1394.     use DbfDir
  1395.     append from ( cTmpFile ) sdf
  1396.     goto top
  1397.     cPath = parspath( cPathSkel )
  1398.     scan
  1399.         replace f_size with fsize( cPath + f_name ),;
  1400.             f_date with fdate( cPath + f_name ),;
  1401.             f_time with ftime( cPath + f_name )
  1402.     endscan
  1403.     nFiles = reccount()
  1404.     use
  1405.     if lSafeOn
  1406.         set safety on
  1407.     endif
  1408.     if "" # cAlias
  1409.         select ( cAlias )
  1410.     endif
  1411.     endif
  1412.     erase ( cTmpFile )
  1413.  
  1414. RETURN nFiles
  1415. *-- EoF: DBFDir()
  1416.  
  1417. FUNCTION ParsPath
  1418. *-------------------------------------------------------------------------------
  1419. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1420. *-- Date........: 07/16/1992
  1421. *-- Notes.......: ParsPath() extracts and returns the path from a
  1422. *--               full path file specification.
  1423. *-- Written for.: dBASE IV v1.1
  1424. *-- Rev. History: 07/16/1992 -- Original
  1425. *-- Calls.......: None
  1426. *-- Called by...: Any
  1427. *-- Usage.......: ParsePath( "<cFullPath>" )
  1428. *-- Example.....: set fullpath on
  1429. *--               cDBF = dbf()
  1430. *--               cPath = ParsPath( cDBF )
  1431. *-- Returns.....: The path only, including the trailing backslash,
  1432. *--               of the full path file specification
  1433. *-- Parameters..: cFullPath = a full path file spec, e.g. "c:\dbase\dbase.exe"
  1434. *-------------------------------------------------------------------------------
  1435.  
  1436.     parameter cFullPath
  1437.     private all
  1438.     cPath = ""
  1439.     if "\" $ cFullPath
  1440.     nPos = 1
  1441.     do while left( right ( cFullPath, nPos ), 1 ) # "\"
  1442.         nPos = nPos + 1
  1443.     enddo
  1444.     cPath = substr( cFullPath, 1, len( cFullPath ) - nPos + 1)
  1445.     endif
  1446.  
  1447. RETURN cPath
  1448. *-- EoF: ParsPath()
  1449.  
  1450. PROCEDURE TagPop
  1451. *-------------------------------------------------------------------------------
  1452. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1453. *-- Date........: 09/08/1992
  1454. *-- Notes.......: Used to bring up a list of MDX tags on screen for the user,
  1455. *--               so they can change the current tag ... This is based on an
  1456. *--               article by Susan Perschke and Mike Liczbanski in "Data Based 
  1457. *--               Advisor", December, 1991, and another by Malcom C. Rubel,
  1458. *--               Data Based Advisor, September, 1992.
  1459. *--                 The idea is to bring up a picklist of all MDX tags for
  1460. *--               the current database file, showing the tag name, and 
  1461. *--               expression, as well as whether or not it's unique, has a
  1462. *--               FOR clause, and whether it's ascending or descending ...
  1463. *--                 However, as an additional bonus, if the user selects one
  1464. *--               of the MDX tags, the current tag is changed to the one the
  1465. *--               user selects. The tag with a "*" by it is the current tag.
  1466. *-- Written for.: dBASE IV, 1.5
  1467. *-- Rev. History: 09/08/1992 -- Version 1
  1468. *--               09/21/1992 -- Version 1.1 -- added more docs and removed
  1469. *--                               reference to parameters of which there are
  1470. *--                               none ... (changed my mind)
  1471. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  1472. *--               CENTER               Procedure in PROC.PRG
  1473. *-- Called by...: Any
  1474. *-- Usage.......: DO TagPop
  1475. *-- Example.....: ON KEY LABEL F8 DO TagPop
  1476. *-- Returns.....: None (well, ok -- it resets the MDX tag if you select one)
  1477. *-- Parameters..: None
  1478. *-------------------------------------------------------------------------------
  1479.  
  1480.     private nBar, cPrompt, cBorder, cTag, nTag, nTagTotal, cFor, cUnique,;
  1481.              cDir, cKey
  1482.     
  1483.     *-- Disable left/right arrow keys to prevent an accidental exit
  1484.     on key label leftarrow  ?? chr(7)
  1485.     on key label rightarrow ?? chr(7)
  1486.     
  1487.     *-- Save current screen
  1488.     save screen to sTag
  1489.     cBorder = set("BORDER")
  1490.     activate screen
  1491.     
  1492.     *-- define the screen/window
  1493.     define window wTagPop from 5,2 to 20,77 double
  1494.     activate screen
  1495.     do shadow with 5,2,20,77
  1496.     activate window wTagPop
  1497.     
  1498.     *-- check to see if there are any tags ... or an active database ...
  1499.     if isblank(alias()) .or. isblank(tag(1))
  1500.     
  1501.         *-- if not, display appropriate error message
  1502.         if isblank(alias())
  1503.             do center with 1,75,"","** No active Database ... **"
  1504.         else
  1505.             do center with 1,75,"","** No active .MDX file for this .DBF **"
  1506.         endif
  1507.         x=inkey(0)  && wait for user to press a key ...
  1508.         
  1509.     else   && we DO have an active database AND active MDX file
  1510.     
  1511.         *-- headings
  1512.         do center with 0,75,"","Select new MDX Tag"
  1513.         @2,1 say "Name"
  1514.         @2,10 say "For"
  1515.         @2,14 say "Unq"
  1516.         @2,18 say "Seq"
  1517.         @2,22 say "Expression"
  1518.         @3,1 say replicate(chr(196),72)  && ─
  1519.         
  1520.         *-- popup will display here
  1521.         
  1522.         *-- footings (as it were)
  1523.         @10,1 say replicate(chr(196),72)  && ─
  1524.         @11,3 say chr(251)+" in 'For' column means there is a 'For' clause"
  1525.         @12,3 say chr(251)+" in 'Unq' column means the tag is set to 'Unique'"
  1526.         @13,3 say chr(24)+" in 'Seq' means tag is 'Ascending', "+;
  1527.             chr(25)+" means tag is descending"
  1528.         
  1529.         *-- define the popup
  1530.         set border to none  && no border for popup
  1531.         define popup pTag from 3,0 to 10,73;
  1532.            message " Press ENTER to select new index order ... ESC to exit ..."
  1533.         nBar = 1                        && first bar
  1534.         *-- place a * if no tag is currently active
  1535.         cPrompt = iif(TagNo()=0,"*"," ")+" No Index"  && bar 1 will always be this
  1536.         cPrompt = cPrompt + space(11)+"(Natural Order)"
  1537.         nTag = 0
  1538.         
  1539.         *-- loop to get the rest of 'em ...
  1540.         nTagTotal = tagcount()           && get total number of tags
  1541.         do while nTag <= nTagTotal       && loop until no more tags
  1542.            define bar nBar of pTag prompt (cPrompt)
  1543.             nTag = nTag + 1
  1544.             cDefault = iif(TagNo() = nTag,"*"," ")  && if current tag ...
  1545.             *-- the fun part of all this is getting the spacing "just right"
  1546.             *-- that's what all the IIF( ....,space(...)) stuff is about
  1547.             cTag    = tag(nTag)+iif(len(tag(nTag))<9,space(9-len(tag(nTag))),"")
  1548.             cFor    = iif(isblank(for(nTag))," ",chr(251))
  1549.             cUnique = iif(unique(nTag),chr(251)," ")
  1550.             cDir    = iif(descending(nTag),chr(25),chr(24)) && up/down arrows ...
  1551.             cKey    = iif(len(key(nTag))>57,left(key(nTag),52)+" ...",key(nTag))
  1552.             cKey    = iif(len(cKey)<57,cKey+space(57-len(cKey)),cKey)
  1553.             *-- here's the actual definition of the bars ...
  1554.            cPrompt = cDefault+cTag+"  "+cFor+"  "+cUnique+"  "+cDir+"  "+cKey
  1555.            nBar = nBar + 1
  1556.         enddo
  1557.         
  1558.         *-- turn it off when an item's been selected (or <Esc> was pressed)
  1559.         on selection popup pTag deactivate popup
  1560.         
  1561.         *-- do it
  1562.         activate popup pTag
  1563.         
  1564.         *-- Don't change index order if ESC pressed
  1565.         if bar() <> 0
  1566.             *-- Assign a null string to cPrompt if "No Index" selected
  1567.             cPrompt = iif(bar() = 1, "",tag(bar()-1))
  1568.            set order to (cPrompt)
  1569.         endif
  1570.         
  1571.         *-- cleanup
  1572.         release popup pTag
  1573.         set border to &cBorder
  1574.         
  1575.     endif
  1576.     deactivate window wTagPop
  1577.     release window wTagPop
  1578.     restore screen from sTag
  1579.     release screen sTag
  1580.     
  1581.     *-- re-enable left/right arrow keys
  1582.     on key label leftarrow
  1583.     on key label rightarrow
  1584.  
  1585. RETURN
  1586. *-- EoP: TagPop
  1587.  
  1588. FUNCTION AAppend
  1589. *-------------------------------------------------------------------------------
  1590. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1591. *-- Date........: 04/01/1992
  1592. *-- Notes.......: Appends a text file into an array. This routine is limited to
  1593. *--               text files of 1,170 lines, and 254 characters per line.
  1594. *--               The text file must be an ASCII Txt formatted file. Taken from
  1595. *--               Technotes, April, 1992.
  1596. *-- Written for.: dBASE IV, 1.5
  1597. *-- Rev. History: 04/01/1992 -- Original
  1598. *-- Calls.......: TextLine()           Function in FILES.PRG
  1599. *-- Called by...: Any
  1600. *-- Usage.......: AAppend(<cFileName>,<aArrayName>)
  1601. *-- Example.....: ?AAppend("CONFIG.DB","aConfig")
  1602. *-- Returns.....: .T.
  1603. *-- Parameters..: cFileName  = Name of DOS Text file to read into array
  1604. *--               aArrayName = Name of array to create. If it already exists,
  1605. *--                            this array will be destroyed and overwritten.
  1606. *-------------------------------------------------------------------------------
  1607.  
  1608.    parameters cFileName, aArrayName
  1609.    private aTArray, nLines, nX, nHandle
  1610.  
  1611.    *-- assign array name to a temp variable name ...
  1612.    aTArray = aArrayName
  1613.    *-- if it exists, get rid of it, and then re-define it
  1614.    release &aTArray
  1615.    public  &aTArray
  1616.    nLines = TextLine(cFileName)  && get number of lines
  1617.    declare &aTArray[min(nLines,1170)]
  1618.  
  1619.    *-- get file handle
  1620.    nHandle = fopen(cFileName)
  1621.  
  1622.    *-- store the file into the array
  1623.    nX = 1
  1624.    do while nX <= nLines
  1625.       store fgets(nHandle,254) to &aTArray[nX]
  1626.       nX = nX + 1
  1627.    enddo
  1628.  
  1629.    *-- close the file
  1630.    nHandle = fClose(nHandle)
  1631.  
  1632. RETURN .T.
  1633. *-- EoF: AAppend()
  1634.  
  1635. FUNCTION FDel
  1636. *-------------------------------------------------------------------------------
  1637. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1638. *-- Date........: 04/01/1992
  1639. *-- Notes.......: Deletes a given portion of a file. Taken from TechNotes,
  1640. *--               April, 1992
  1641. *--                 Used to delete a portion of a file (text or binary) from
  1642. *--               the beginning of the file, the end of file or current pointer
  1643. *--               position. This routine accomplishes it's task by writing the
  1644. *--               data you want to keep to a temp file, then overwriting
  1645. *--               the data you no longer want with the temp file. If you are on
  1646. *--               a network, make sure that you set TMP (or DBTMP) to either
  1647. *--               a local drive, or one where you have full rights.
  1648. *-- Written for.: dBASE IV, 1.5
  1649. *-- Rev. History: 04/01/1992 -- Original
  1650. *-- Calls.......: TempFile()           Function in FILES.PRG
  1651. *-- Called by...: Any
  1652. *-- Usage.......: FDel(<nHandle>,<nBytes>,<nStart>)
  1653. *-- Example.....: nOpen = fopen("TEXT.TXT","RW")
  1654. *--               ?FDel(nOpen,1000,1)
  1655. *-- Returns.....: Logical
  1656. *-- Parameters..: nHandle = file handle number, as returned by FOPEN
  1657. *--               nBytes  = number of characters (bytes) to delete in file
  1658. *--               nStart  = starting position, where:
  1659. *--                          0 is the beginning of the file
  1660. *--                          1 is the current file pointer position
  1661. *--                          2 is the end of the file
  1662. *-------------------------------------------------------------------------------
  1663.  
  1664.    parameters nHandle, nBytes, nStart
  1665.    private nTemp,cTemp,nSave,nSeek,nRead,nWrite,lFlush,nClose
  1666.  
  1667.    *-- create a temporary file
  1668.    cTemp = tempfile("ADM")
  1669.    *-- save current position in file
  1670.    nSave = fseek(nHandle,0,1)
  1671.  
  1672.    do case
  1673.       case nStart = 0                  && beginning of file
  1674.        nSeek = fseek(nHandle,nBytes,0)
  1675.        nTemp = fcreate(cTemp)
  1676.        do while .not. feof(nHandle)
  1677.           nRead = fread(nHandle,254)
  1678.           nWrite = fwrite(nTemp,nRead)
  1679.           lFlush = fflush(nTemp)
  1680.        enddo
  1681.        nSeek = fseek(nTemp,0,0)
  1682.        nSeek = fseek(nHandle,0,0)
  1683.        do while .not. feof(nTemp)
  1684.           nRead = fread(nTemp,254)
  1685.           nWrite = fwrite(nHandle,nRead)
  1686.           lFlush = fflush(nHandle)
  1687.        enddo
  1688.        nWrite = fwrite(nHandle,chr(0),0)
  1689.        nClose = fclose(nTemp)
  1690.        nSeek = fseek(nHandle,nSave,0)
  1691.  
  1692.       case nStart = 1                  && Current Location
  1693.        *-- skip these bytes
  1694.        nSeek = fseek(nHandle,nDelete,1)
  1695.        *-- write the rest to a temp file
  1696.        nTemp=fCreate(cTemp)
  1697.        do while .not. feof(nHandle)
  1698.           nRead = fread(nHandle,254)
  1699.           nWrite = fwrite(nTemp,nRead)
  1700.           lFlush = fflush(nTemp)
  1701.        enddo
  1702.  
  1703.        nSeek = fseek(nTemp,0,0)
  1704.        nSeek = fseek(nHandle,nSave,0)
  1705.        nWrite = fwrite(nHandle,chr(0),0)
  1706.  
  1707.        do while .not. feof(nTemp)
  1708.           nRead = fread(nTemp,254)
  1709.           nWrite = fwrite(nHandle,nRead)
  1710.           lFlush = fflush(nHandle)
  1711.        enddo
  1712.        nSeek = fseek(nHandle,nSave,0)
  1713.        nClose = fclose(nTemp)
  1714.  
  1715.       case nStart = 2                  && End of File
  1716.        nSeek = fseek(nHandle,-1*abs(nDelete),2)
  1717.        nWrite = fwrite(nHandle,chr(0),0)
  1718.    endcase
  1719.    erase (cTemp)
  1720.  
  1721. RETURN (ferror() = 0)
  1722. *-- EoF: FDel()
  1723.  
  1724. FUNCTION FGetLine
  1725. *-------------------------------------------------------------------------------
  1726. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1727. *-- Date........: 04/01/1992
  1728. *-- Notes.......: Used to extract a line of text from a text file. 
  1729. *-- Written for.: dBASE IV, 1.5
  1730. *-- Rev. History: 04/01/1992 -- Original
  1731. *-- Calls.......: TLine()              Function in FILES.PRG
  1732. *--               TLineNo()            Function in FILES.PRG
  1733. *-- Called by...: Any
  1734. *-- Usage.......: FGetLine(<cFileName>,<cLookup>,[<lCase>],[<lEntire>])
  1735. *-- Example.....: ?FGetLine("config.db","command",.f.,.f.)
  1736. *-- Returns.....: A character expression
  1737. *-- Parameters..: cFileName = Name of file to extract text from
  1738. *--               cLookup   = Text to look for
  1739. *--               lCase     = Case sensitive? (Logical = .t. or .f.)
  1740. *--                           If empty, default is .F.
  1741. *--               lEntire   = Return entire line, or the rest of the line
  1742. *--                           .t. = return the entire line
  1743. *--                           .f. = return everything following cLookup
  1744. *--                           If empty, default is .t.
  1745. *-------------------------------------------------------------------------------
  1746.  
  1747.    parameters cFileName, cLookup, lCase, lEntire
  1748.    private nLine, cText
  1749.  
  1750.    *-- defaults
  1751.    lCase   = iif(pcount() <= 2,.f.,lCase)
  1752.    lEntire = iif(pcount() <=3,.t.,lEntire)
  1753.    *-- get the line ...
  1754.    nLine = TLineNo(cFile,cLookup,lCase)
  1755.    cText = iif(nLine<=0,"",TLine(cFile,nLine,lCase))
  1756.    cResult = upper(cText)
  1757.  
  1758. RETURN iif(lEntire,cText,substr(cText,at(upper(cLookup),cResult)+len(cLookup)))
  1759. *-- EoF: FGetLine()
  1760.  
  1761. FUNCTION FIns
  1762. *-------------------------------------------------------------------------------
  1763. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1764. *-- Date........: 04/01/1992
  1765. *-- Notes.......: Inserts specified number of NULLS into a low-level file.
  1766. *--               Taken from Technotes, April, 1992. FIns() works the way
  1767. *--               FDel() works, but in reverse.  See comments in FDel about
  1768. *--               temp directory ...
  1769. *-- Written for.: dBASE IV, 1.5
  1770. *-- Rev. History: 04/01/1992 -- Original
  1771. *-- Calls.......: TempFile()           Function in FILES.PRG
  1772. *-- Called by...: Any
  1773. *-- Usage.......: FIns(<nHandle>,<nBytes>,<nStart>)
  1774. *-- Example.....: nOpen = fopen("TEST.TXT","RW")
  1775. *--               ?FIns(nOpen,10,1)
  1776. *-- Returns.....: Logical
  1777. *-- Parameters..: nHandle = File Handle from FOPEN() function
  1778. *--               nBytes  = Number of nulls to insert into file
  1779. *--               nStart  = Location in file to start at, where:
  1780. *--                         0 = Beginning of file
  1781. *--                         1 = Current file pointer
  1782. *--                         2 = End of file
  1783. *-------------------------------------------------------------------------------
  1784.  
  1785.    parameters nHandle, nBytes, nStart
  1786.    private nTemp, cTemp, nSave, nRead, nWrite, nSeek, lFlush, nX, nClose
  1787.  
  1788.    cTemp = TempFile("ADM")      && create temp file
  1789.    nSave = fseek(nHandle,0,1)   && save current position
  1790.  
  1791.    do case
  1792.       case nStart = 0           && beginning of file
  1793.        nTemp = fcreate(cTemp)
  1794.        nX = 1
  1795.        do while nX <= nBytes
  1796.           nWrite = fwrite(nTemp,chr(0),1)
  1797.           nX = nX + 1
  1798.        enddo
  1799.        nSeek = fseek(nHandle,0,0)
  1800.        do while .not. feof(nHandle)
  1801.           nRead = fread(nHandle,254)
  1802.           nWrite = fwrite(nTemp,nRead)
  1803.           lFlush = fflush(nTemp)
  1804.        enddo
  1805.        nSeek = fseek(nTemp,0,0)
  1806.        nSeek = fseek(nHandle,0,0)
  1807.        do while .not. feof(nTemp)
  1808.           nRead = fread(nTemp,254)
  1809.           nWrite = fwrite(nHandle,nRead)
  1810.           lFlush = fflush(nHandle)
  1811.        enddo
  1812.        nWrite = fwrite(nHandle,chr(0),0)
  1813.        nclose = fclose(ntemp)
  1814.        nSeek = fseek(nHandle,0,0)
  1815.  
  1816.       case nStart = 1                  && current location
  1817.        *-- write the rest to a temp file
  1818.        nTemp = fcreate(cTemp)
  1819.        do while .not. feof(nHandle)
  1820.           nRead = fread(nHandle,254)
  1821.           nWrite = fwrite(nTemp,nRead)
  1822.           lFlush = fflush(nTemp)
  1823.        enddo
  1824.        nSeek = fseek(nHandle,nSave,0)
  1825.        nX = 1
  1826.        do while nX <= nBytes
  1827.           nWrite = fWrite(nHandle,chr(0),1)
  1828.           nX = nX + 1
  1829.        enddo
  1830.        nSeek = fseek(nTemp,0,0)
  1831.        do while .not. feof(nTemp)
  1832.           nRead = fread(nTemp,254)
  1833.           nWrite = fwrite(nHandle,nRead)
  1834.           lFlush = fflush(nHandle)
  1835.        enddo
  1836.        nSeek = fseek(nHandle,nSave,0)
  1837.        nClose = fclose(nTemp)
  1838.  
  1839.       case nStart = 2                  && End of File
  1840.        nSeek = fseek(nHandle,0,2)
  1841.        nX = 1
  1842.        do while nX <= nBytes
  1843.           nWrite = fwrite(nHandle,chr(0),1)
  1844.           nX = nX + 1
  1845.        enddo
  1846.    endcase
  1847.    erase (cTemp)
  1848.  
  1849. RETURN (ferror() = 0)
  1850. *-- EoF: FIns()
  1851.  
  1852. FUNCTION GetInfo
  1853. *-------------------------------------------------------------------------------
  1854. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1855. *-- Date........: 04/01/1992 
  1856. *-- Notes.......: This retrieves information from STATUS that you cannot get
  1857. *--               with the dBASE IV function SET(). See 'parameters' below for
  1858. *--               list of keywords.
  1859. *--               CAUTION: If you have ALTERNATE set, you need to reset it after
  1860. *--                 the function executes. SET ALTERNATE TO must be used instead
  1861. *--                 of LIST STATUS TO filename, since the print destination
  1862. *--                 would always show as a file. All results that are returned
  1863. *--                 are returned as character types, including ones that
  1864. *--                 return numbers (use VAL() to look at/use returned value as
  1865. *--                 a number).
  1866. *-- Written for.: dBASE IV, 1.5
  1867. *-- Rev. History: 04/01/1992 -- Original
  1868. *-- Calls.......: TempFile()           Function in FILES.PRG
  1869. *--               TextLine()           Function in FILES.PRG
  1870. *--               AAppend()            Function in FILES.PRG
  1871. *-- Called by...: Any
  1872. *-- Usage.......: GetInfo(<cKeyWord>,[<cKeyWord2>])
  1873. *-- Example.....: ? GetInfo("F5")
  1874. *-- Returns.....: Character expression
  1875. *-- Parameters..: cKeyWord  = Item you are looking for status of, options 
  1876. *--                           listed return the following:
  1877. *--                           WORK    Number of work area you are currently
  1878. *--                                   in - whether or not a database is in use.
  1879. *--                           PRINT   Current printer destination where output
  1880. *--                                   is directed (PRN, NUL, LPT1, COM1) as 
  1881. *--                                   set by SET PRINTER TO.
  1882. *--                           ERROR   The error condition set by ON ERROR
  1883. *--                           ESCAPE  The escape condition set by ON ESCAPE
  1884. *--                           F2 to F10, Ctrl-F1 to Ctrl-F10, Shift-F1 to
  1885. *--                              Shift-F10 
  1886. *--                                   The current setting of each key as set
  1887. *--                                   by SET FUNCTION <label> TO
  1888. *--                           **** The following require a second paramter
  1889. *--                                (cKeyWord2 ...)
  1890. *--                           PAGE,LINE  Line number specified by 
  1891. *--                                                 ON PAGE AT LINE
  1892. *--                                      in the page handling routine
  1893. *--                           HANDLE,<filename>  The handle number of the low-
  1894. *--                                      level file specified by <filename>
  1895. *--                           NAME,<filehandle>  The file name of the low-level
  1896. *--                                      file specified by <filehandle>
  1897. *--                           MODE,<filehandle>  The privilege of the low-level
  1898. *--                                      file specified by <filehandle>
  1899. *--               cKeyWord2 = see list above ...
  1900. *-------------------------------------------------------------------------------
  1901.  
  1902.    parameters cKeyWord, cKeyWord2
  1903.    private cKey, l2Parms, cStart, cSafety, cTempTxt, nLines, cTmpArray
  1904.  
  1905.    cKey = upper(cKeyWord)
  1906.    l2Parms = (pcount() = 2)
  1907.  
  1908.    do case
  1909.       case cKey = "CTRL-" .or. cKey = "SHIFT" .or. ;
  1910.        (","+cKey+"," $ ",F2,F3,F4,F5,F6,F7,F8,F9,F10,")
  1911.        cStart = cKey + space(9 - len(cKey))+"-"
  1912.  
  1913.       case cKey = "PRINT"
  1914.        cStart = "Print Destination:"
  1915.  
  1916.       case cKey = "WORK"
  1917.        cStart = "Current work area ="
  1918.        if "" <> dbf()
  1919.           RETURN select(alias())
  1920.        endif
  1921.  
  1922.       case cKey = "ERROR"
  1923.        cStart = "On Error:"
  1924.     
  1925.       case cKey = "ESCAPE"
  1926.        cStart = "On Escape:"
  1927.  
  1928.       case cKey = "PAGE"
  1929.        cStart = "On Page At Line"
  1930.  
  1931.       case cKey = "HANDLE" .or. cKey = "NAME" .or. cKey = "MODE"
  1932.        cStart = "Low level files opened"
  1933.  
  1934.       otherwise      && none of the above
  1935.        RETURN ""
  1936.  
  1937.    endcase
  1938.  
  1939.    cSafety = set("SAFETY")
  1940.    cTempTxt = TempFile()
  1941.    *-- get status info (into a temp file), which will then be parsed to extract
  1942.    *-- information requested ...
  1943.    set console off
  1944.    set alternate to &cTempTxt.  && create file without extension
  1945.    set alternate on
  1946.    list status
  1947.    close alternate
  1948.    set console on
  1949.    
  1950.    nLines = TextLine(cTempTxt)
  1951.    aTmpArray = right(cTempTxt,8)
  1952.    cTmp = AAppend(cTempTxt,aTmpArray)
  1953.    nHandle = fopen(cTempTxt,"R")
  1954.    cResult = ""
  1955.  
  1956.    nX = 1
  1957.    do while nX <= nLines
  1958.       if left(&aTmpArray[nX],len(cStart)) = cStart
  1959.      cResult = ltrim(substr(&aTmpArray[nX],len(cStart)+1))
  1960.      exit
  1961.       endif
  1962.       nX = nX + 1
  1963.    enddo
  1964.  
  1965.    *-- 2 parameters?
  1966.    if l2Parms .and. "" # cResult
  1967.       do case
  1968.      case cKey = "PAGE"
  1969.           if upper(cKeyWord2) = "LINE"
  1970.          cResult = left(cResult,at(" ",cResult) - 1)
  1971.           else
  1972.          cResult = substr(cResult,at(" ",cResult) + 1)
  1973.           endif
  1974.  
  1975.      case cKey = "HANDLE" .or. cKey = "NAME" .or. cKey = "MODE"
  1976.           cResult = ""
  1977.           nX = nX + 2
  1978.           do while val(&aTmpArray[nX]) <> 0
  1979.          do case
  1980.             case cKey = "HANDLE" .and. upper(cKeyWord2) $ &aTmpArray[nX]
  1981.              cResult = str(val(&aTmpArray[nX]))
  1982.  
  1983.             case cKey = "NAME" .and. cKeyWord2 = val(&aTmpArray[nX])
  1984.              cResult = substr(&aTmpArray[nX],10,40)
  1985.  
  1986.             case cKey = "MODE" .and. cKeyWord2 = val(&aTmpArray[nX])
  1987.              cResult = substr(&aTmpArray[nX],50,5)
  1988.           endcase
  1989.           if "" <> cResult
  1990.              exit
  1991.           endif
  1992.           nX = nX + 1
  1993.           enddo
  1994.       endcase
  1995.    endif
  1996.  
  1997.    relase &aTmpArray
  1998.    nClose = fclose(nHandle)
  1999.    set safety off
  2000.    erase (cTempTxt)
  2001.    set safety &cSafety
  2002.    cResult = ltrim(rtrim(cResult))
  2003.  
  2004. RETURN iif(right(cResult,1) = ":",;
  2005.       left(cResult,len(cResult-1)),cResult)
  2006. *-- EoF: GetInfo()
  2007.  
  2008. FUNCTION TextLine
  2009. *-------------------------------------------------------------------------------
  2010. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2011. *-- Date........: 04/01/1992
  2012. *-- Notes.......: Returns the number of lines of text in an ASCII Text File
  2013. *--               Taken from TechNotes, April, 1992
  2014. *-- Written for.: dBASE IV, 1.5
  2015. *-- Rev. History: 04/01/1992 -- Original
  2016. *-- Calls.......: None
  2017. *-- Called by...: Any
  2018. *-- Usage.......: TextLine(<cTextFile>)
  2019. *-- Example.....: ?TextLine("CONFIG.DB")
  2020. *-- Returns.....: Number of lines
  2021. *-- Parameters..: cTextFile = name of file
  2022. *-------------------------------------------------------------------------------
  2023.  
  2024.    parameter cTextFile
  2025.    private nLines, nHandle, cTemp, nClose
  2026.  
  2027.    nLines = 0
  2028.    if file(cTextFile)   && if it exists ...
  2029.       nHandle = fopen(cTextFile,"R")
  2030.       do while .not. feof(nHandle)
  2031.      cTemp = fgets(nHandle,254)
  2032.      nLines = nLines + 1
  2033.       enddo
  2034.       nClose = fclose(nHandle)
  2035.    endif
  2036.  
  2037. RETURN nLines
  2038. *-- EoF: TextLine()
  2039.  
  2040. FUNCTION TLine
  2041. *-------------------------------------------------------------------------------
  2042. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2043. *-- Date........: 04/01/1992
  2044. *-- Notes.......: Returns a specific line in an ASCII Text File. This is similar
  2045. *--               to the way MLINE() works on a memo field. Taken from TechNotes
  2046. *--               April, 1992.
  2047. *-- Written for.: dBASE IV, 1.5
  2048. *-- Rev. History: 04/01/1992 -- Original
  2049. *-- Calls.......: None
  2050. *-- Called by...: Any
  2051. *-- Usage.......: TLine(<cTextFile>,<nLine>)
  2052. *-- Example.....: ?TLine("CONFIG.DB",20)
  2053. *-- Returns.....: Character expression - specified line of text file.
  2054. *-- Parameters..: cTextFile = name of text file
  2055. *--               nLine     = line to return from text file
  2056. *-------------------------------------------------------------------------------
  2057.  
  2058.    parameters cTextFile, nLine
  2059.    private cText, nX, nHandle, nClose
  2060.  
  2061.    cText = ""
  2062.    nX = 1
  2063.    if file(cTextFile)    && if file exists ...
  2064.       nHandle = fopen(cTextFile,"R")
  2065.       do while .not. feof(nHandle)
  2066.      cText = fgets(nHandle,254)
  2067.      if nX = nLine
  2068.         exit
  2069.      endif
  2070.      nX = nX + 1
  2071.       enddo
  2072.       nClose = fclose(nHandle)
  2073.    endif
  2074.  
  2075. RETURN cText
  2076. *-- EoF: TLine()
  2077.  
  2078. FUNCTION TLineNo
  2079. *-------------------------------------------------------------------------------
  2080. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2081. *-- Date........: 04/01/1992
  2082. *-- Notes.......: Returns the line number of the phrase you are searching for
  2083. *--               in an ASCII Text File. This is similar to dBASE's AT() 
  2084. *--               function, but works on LINES rather than CHARACTERS.
  2085. *--               Taken from TechNotes, April, 1992
  2086. *-- Written for.: dBASE IV, 1.5
  2087. *-- Rev. History: 04/01/1992 -- Original
  2088. *-- Calls.......: None
  2089. *-- Called by...: Any
  2090. *-- Usage.......: TLineNo(<cTextFile>,<cLookup>,[<lCase>])
  2091. *-- Example.....: ?TLineNo("CONFIG.DB","command",.f.)
  2092. *-- Returns.....: numeric value (the line number containing the line needed)
  2093. *--               returns -1 if not found
  2094. *-- Parameters..: cTextFile = Name of ASCII Text File
  2095. *--               cLookup   = Text to search for ...
  2096. *--               lCase     = Case Sensitive? (Default is .F.)
  2097. *-------------------------------------------------------------------------------
  2098.  
  2099.    parameters cTextFile, cLookup, lCase
  2100.    private cPhrase, nHandle, cText, nX, nClose
  2101.  
  2102.    if pCount() = 3 .and. lCase
  2103.       lCase = .t.
  2104.       cPhrase = cLookup
  2105.    else
  2106.       lCase = .f.
  2107.       cPhrase = upper(cLookup)
  2108.    endif
  2109.  
  2110.    cText = ""
  2111.    nX = 1
  2112.    if file(cTextFile)
  2113.       nHandle = fopen(cTextFile,"R")
  2114.       do while .not. feof(nHandle)
  2115.      cText = fgets(nHandle,254)
  2116.      if at(cPhrase,iif(lCase,cText,upper(cText))) > 0
  2117.         nClose = fclose(nHandle)
  2118.         RETURN nX
  2119.      endif
  2120.      nX = nX + 1
  2121.       enddo
  2122.  
  2123.       nClose = fclose(nHandle)
  2124.    endif
  2125.  
  2126. RETURN -1
  2127. *-- EoF: TLineNo()
  2128.  
  2129. FUNCTION TempFile
  2130. *-------------------------------------------------------------------------------
  2131. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2132. *-- Date........: 04/01/1992
  2133. *-- Notes.......: Returns a random filename.
  2134. *-- Written for.: dBASE IV, 1.5
  2135. *-- Rev. History: 04/01/1992 -- Original
  2136. *-- Calls.......: TempDir()            Function in FILES.PRG
  2137. *-- Called by...: Any
  2138. *-- Usage.......: TempFile([cFileExt])
  2139. *-- Example.....: cVarFile = TempFile("$XY")
  2140. *-- Returns.....: Filename
  2141. *-- Parameters..: cFileExt = optional parameter - allows you to assign a
  2142. *--                          file extension to the end of the filename.
  2143. *-------------------------------------------------------------------------------
  2144.  
  2145.    parameters cFileExt
  2146.  
  2147. RETURN TempDir()+"TMP"+right(ltrim(str(rand(-1)*10000000)),5);
  2148.        +iif(pcount() = 0 .or. "" = cFileExt,"","."+cFileExt)
  2149. *-- EoF: TempFile()
  2150.  
  2151. FUNCTION TempDir
  2152. *-------------------------------------------------------------------------------
  2153. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2154. *-- Date........: 04/01/1992
  2155. *-- Notes.......: Returns path of temporary directory as set from DOS
  2156. *--               (i.e., SET DBTMP= ...) Taken from TechNotes, April, 1992
  2157. *-- Written for.: dBASE IV, 1.5
  2158. *-- Rev. History: 04/01/1992 -- Original
  2159. *-- Calls.......: GetEnv()             Function in FILES.PRG
  2160. *-- Called by...: Any
  2161. *-- Usage.......: TempDir()
  2162. *-- Example.....: ?TempDir()
  2163. *-- Returns.....: Path of temporary directory
  2164. *-- Parameters..: None
  2165. *-------------------------------------------------------------------------------
  2166.  
  2167.   cTempDir = iif("" <> GetEnv("DBTMP"),GetEnv("DBTMP"),GetEnv("TMP"))
  2168.  
  2169. RETURN cTempDir+iif(right(cTempDir,1)<> "\" .and.;
  2170.      left(os(),3) = "DOS" .and. .not. "" = cTempDir,"\","")
  2171. *-- EoF: TempDir()
  2172.  
  2173. FUNCTION DirList
  2174. *-------------------------------------------------------------------------------
  2175. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  2176. *-- Date........: 02/01/1993
  2177. *-- Notes.......: Used to display a popup of the hierarchical structure
  2178. *--               of directories. With this you can select a directory from
  2179. *--               the popup. 
  2180. *--               DirList() returns a DOS Error Number if it encounters one,
  2181. *--               or a -1 if it fails to perform its task. It 
  2182. *--               Originally Printed in TechNotes, February 1993
  2183. *--               ************************************************
  2184. *--               *** REQUIRES DOS TREE COMMAND BE IN DOS PATH ***
  2185. *--               ************************************************
  2186. *-- Written for.: dBASE IV, 1.5
  2187. *-- Rev. History: 02/01/1993 -- Original Release
  2188. *-- Calls.......: WhatDir              Procedure in FILES.PRG
  2189. *-- Called by...: Any
  2190. *-- Usage.......: DirList([<cDrive>])
  2191. *-- Example.....: ?DirList()    or
  2192. *--               ?DirList("A:")
  2193. *-- Returns.....: See above
  2194. *-- Parameters..: cDrive = Optional Parameter to list a specific drive instead
  2195. *--                        of the default.
  2196. *-------------------------------------------------------------------------------
  2197.  
  2198.     parameters cDrive
  2199.     
  2200.     *-- deal with possible errors
  2201.     do case
  2202.         case .not. "DOS" $ UPPER(OS())  && gotta be DOS, not UNIX
  2203.             RETURN "Incompatible operating system"
  2204.         case pcount() # 0 .and. type("cDRIVE") # "C"
  2205.             RETURN "Invalid Parameter"
  2206.         case type("cDrive") = "C" .and. .not. isalpha(left(cDrive,1))
  2207.             RETURN "Invalid Parameter"
  2208.     endcase
  2209.     
  2210.     *-- deal with file already being there
  2211.     if file("DIRECT.XXX")
  2212.         erase direct.xxx
  2213.     endif
  2214.     
  2215.     *-- save screen and then clear whatever's on it
  2216.     save screen to sDirList
  2217.     clear
  2218.     
  2219.     *-- get the "message" color from the attributes ....
  2220.     cMsgColor = substr(set("ATTRIBUTE"),at(chr(38),set("ATTRIBUTE"))+3)
  2221.     cMsgColor = substr(cMsgColor,at(",",cMsgColor)+1)
  2222.     cMsgColor = substr(cMsgColor,at(",",cMsgColor)+1)
  2223.     cMsgColor = left(cMsgColor,at(",",cMsgColor)-1)
  2224.     
  2225.     *-- display message (slightly modified by KJM)
  2226.     @ 9,22 fill to 13,60 color n+/n  && shadow
  2227.     @ 8,20 fill to 12,58 color &cMsgColor.
  2228.     @ 8,20 to 12,58 double color &cMsgColor.
  2229.     @10,22 say "The directory tree is being created" color &cMsgColor.
  2230.     
  2231.     *-- execute DOS RUN command, putting output into a text file
  2232.     if type("CDRIVE") = "L"
  2233.         * tree must be run in DOS directory or in DOS path
  2234.         nRun = run(.f.,"TREE \ > direct.XXX",.t.)
  2235.     else
  2236.         cDrive = left(cDrive,1)+":\"
  2237.         nRun = run(.f.,"TREE &cDrive > direct.xxx",.t.)
  2238.     endif
  2239.     
  2240.     *-- error has occured of some sort -- return error number OR -1
  2241.     if nRun # 0 .or. .not. file("DIRECT.XXX")
  2242.         RETURN iif(nRun # 0,nRun, -1)
  2243.     endif
  2244.  
  2245.     *-- use low-level routines to go in and deal with the file ...
  2246.     nHandle = fopen("DIRECT.XXX","R")   && open text file
  2247.     cMove   = fGets(nHandle,":")
  2248.     if feof(nHandle)
  2249.         lClose = fClose(nHandle)
  2250.         erase direct.xxx
  2251.         restore screen from sDirList
  2252.         release screen sDirList
  2253.         RETURN - 1
  2254.     endif
  2255.     cMove = fSeek(nHandle,len(cMove)-1)
  2256.     
  2257.     *-- define the popup
  2258.     define popup pTree from 1,20
  2259.     nBar = 1
  2260.     do while .not. feof(nHandle)
  2261.         define bar nBar of pTree prompt space(2)+fGets(nHandle)+space(5)
  2262.         nBar = nBar + 1
  2263.     enddo
  2264.     
  2265.     *-- store path (bar) and location of ascii 195 (├) or 192 (└) to array
  2266.     declare aTemp[nBar,2]    && temp array
  2267.     nBar = 1
  2268.     cMove = fSeek(nHandle,0,0)
  2269.     cMove = fGets(nHandle,":")
  2270.     cMove = fSeek(nHandle,len(cMove) - 1)
  2271.     do while .not. feof(nHandle)
  2272.         cBar = trim(fGets(nHandle))
  2273.         store cBar to aTemp[nBar,1]
  2274.         store iif(at(chr(195),cBar) # 0, at(chr(195),cBar),;
  2275.                 at(chr(192),cBar)) to aTemp[nBar,2]
  2276.         nBar = nBar + 1
  2277.     enddo
  2278.     
  2279.     *-- hokay ... 
  2280.     clear
  2281.     cUser = ""
  2282.     *-- when user selects something, execute routine WhatDir ...
  2283.     on selection popup pTree do whatdir with bar(),cUser
  2284.     activate popup pTree
  2285.     release popup pTree
  2286.     lClose = fClose(nHandle)
  2287.     erase direct.xxx
  2288.     restore screen from sDirList
  2289.     release screen sDirList
  2290.  
  2291. RETURN cUser
  2292. *-- EoF: DirList()
  2293.  
  2294. PROCEDURE WhatDir
  2295. *-------------------------------------------------------------------------------
  2296. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  2297. *-- Date........: 02/01/1993
  2298. *-- Notes.......: Part of DIRLIST() above -- this is used to extract out of
  2299. *--               the prompt from a popup, the directory a user selected ...
  2300. *--               This routine should not be used on its own ... it assumes
  2301. *--               too much (like array aTemp[] being in existance, and such)
  2302. *-- Written for.: dBASE IV, 1.5
  2303. *-- Rev. History: 02/01/1993 -- Original Release
  2304. *-- Calls.......: GRAt()               Function in FILES.PRG
  2305. *-- Called by...: DirList()
  2306. *-- Usage.......: Do WhatDir with <nBar>,<cDir>
  2307. *-- Example.....: Do WhatDir with bar(),cUser
  2308. *-- Returns.....: Directory
  2309. *-- Parameters..: nBar  = bar number of popup
  2310. *--               cDir  = prompt from popup to extract data ...
  2311. *-------------------------------------------------------------------------------
  2312.  
  2313.     parameters nBar, cDir
  2314.     
  2315.     if nBar # 1
  2316.         cDir = substr(aTemp[nBar,1],GRAt(aTemp[nBar,1])+1)
  2317.         nLevel = aTemp[nBar,2]
  2318.         nBar = nBar - 1
  2319.         do while nBar # 1
  2320.             if aTemp[nBar,2] < nLevel
  2321.                 cDir = substr(aTemp[nBar,1],GRAt(aTemp[nBar,1])+1)+"\"+cDir
  2322.                 nLevel = aTemp[nBar,2]
  2323.             endif
  2324.             nBar = nBar - 1
  2325.         enddo
  2326.         cDir = aTemp[1,1]+cDir
  2327.     else
  2328.         cDir = aTemp[1,1]
  2329.     endif
  2330.     deactivate popup
  2331.  
  2332. RETURN
  2333. *-- EoP: WhatDir
  2334.  
  2335. FUNCTION GRAt
  2336. *-------------------------------------------------------------------------------
  2337. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  2338. *-- Date........: 02/01/1993
  2339. *-- Notes.......: Graphic Reverse At -- Returns position of the first graphic
  2340. *--               character from the right of the string.
  2341. *--               Originally printed in TechNotes, February, 1993
  2342. *-- Written for.: dBASE IV, 1.5
  2343. *-- Rev. History: 02/01/1993 -- Original Release
  2344. *-- Calls.......: None
  2345. *-- Called by...: WhatDir
  2346. *-- Usage.......: GRAt(<cString>)
  2347. *-- Example.....: n = GRAt(cBar)
  2348. *-- Returns.....: Numeric
  2349. *-- Parameters..: cString = string to search
  2350. *-------------------------------------------------------------------------------
  2351.  
  2352.     parameters cString
  2353.     
  2354.     nLen = len(cString)
  2355.     lFound = .f.
  2356.     
  2357.     do while nLen # 0
  2358.         cChar = substr(cString,nLen,1)
  2359.         if asc(cChar) > 175 .and. asc(cChar) < 224
  2360.             lFound = .t.
  2361.             exit
  2362.         endif
  2363.         nLen = nLen - 1
  2364.     enddo
  2365.     
  2366. RETURN iif(lFound,nLen,-1)
  2367. *-- EoF: GRAt()
  2368.  
  2369. FUNCTION FF
  2370. *-------------------------------------------------------------------------------
  2371. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  2372. *-- Date........: 02/01/1993
  2373. *-- Notes.......: This routine will search a disk and find all occurances
  2374. *--               of a specified file or files. It will then allow you
  2375. *--               to select said file.
  2376. *--               Originally printed in TechNotes, February, 1993
  2377. *--               *********************************
  2378. *--               **** USES DOS ATTRIB COMMAND ****
  2379. *--               *********************************
  2380. *-- Written for.: dBASE IV, 1.5
  2381. *-- Rev. History: 02/01/1993 -- Original Release
  2382. *-- Calls.......: None
  2383. *-- Called by...: Any
  2384. *-- Usage.......: FF(<cFile>[,<cPath>])
  2385. *-- Example.....: ?ff("*.dbf","c:\temp")
  2386. *-- Returns.....: Selected File
  2387. *-- Parameters..: cFile  = Filename, or wildcard specification, allows use
  2388. *--                        of standard ? and * wildcards in the way DOS has
  2389. *--                        always used them.
  2390. *--               cPath  = Optional -- specified drive and directory.
  2391. *--                        If not used, this UDF will start the search at
  2392. *--                        the root of the default drive.
  2393. *-------------------------------------------------------------------------------
  2394.  
  2395.     parameters cFile,cPath
  2396.     
  2397.     cCurDir = set("DIRECTORY")
  2398.     
  2399.     *-- deal with error messages
  2400.     do case
  2401.         case type("CFILE") # "C"
  2402.             RETURN "Invalid Parameter"
  2403.         case pcount() > 1 .and. type("CFILE") # "C"
  2404.             RETURN "Invalid Parameter"
  2405.         case pcount() > 1 .and. type("CFILE") = "C"
  2406.             lError = .f.
  2407.             on error lError = .t.
  2408.             set directory to &cPath.
  2409.             on error
  2410.             if lError
  2411.                 RETURN "Invalid Drive\Directory"
  2412.             endif
  2413.     endcase
  2414.     
  2415.     if file("TEMP.XXX")
  2416.         erase temp.xxx
  2417.     endif
  2418.     
  2419.     *-- save screen so we can restore it, and clear ...
  2420.     save screen to sFF
  2421.     clear
  2422.     
  2423.     *-- get the "message" color from the attributes ....
  2424.     cMsgColor = substr(set("ATTRIBUTE"),at(chr(38),set("ATTRIBUTE"))+3)
  2425.     cMsgColor = substr(cMsgColor,at(",",cMsgColor)+1)
  2426.     cMsgColor = substr(cMsgColor,at(",",cMsgColor)+1)
  2427.     cMsgColor = left(cMsgColor,at(",",cMsgColor)-1)
  2428.     
  2429.     *-- display message 
  2430.     @ 9,22 fill to 13,60 color n+/n  && shadow
  2431.     @ 8,20 fill to 12,58 color &cMsgColor.
  2432.     @ 8,20 to 12,58 double color &cMsgColor.
  2433.     @10,22 say "The directories are being searched" color &cMsgColor.
  2434.     
  2435.     *-- if no path was given, run the DOS Attrib command on the whole drive
  2436.     if type("CPATH") = "L"
  2437.         nDosF = run(.f.,"ATTRIB \&cFile. /s > temp.xxx | sort",.t.)
  2438.     else  && run it on the path that was given ...
  2439.         nDosF = run(.f.,"ATTRIB  &cFile. /s > temp.xxx | sort",.t.)
  2440.     endif
  2441.     
  2442.     *-- if there was an error ...
  2443.     if nDosF # 0 .or. .not. file("TEMP.XXX")
  2444.         set directory to &cCurDir.
  2445.         restore screen from sFF
  2446.         release screen sFF
  2447.         RETURN iif(nDosF # 0,nDosF,-1)
  2448.     endif
  2449.     
  2450.     *-- use LOWLEVEL routines to process the output of the ATTRIB command
  2451.     nHandle = fopen("TEMP.XXX","R")
  2452.     cMove   = fgets(nHandle,":")
  2453.     if feof(nHandle)
  2454.         lClose = fClose(nHandle)
  2455.         erase temp.xxx
  2456.         restore screen from sFF
  2457.         release screen sFF
  2458.         RETURN "File not found"
  2459.     endif
  2460.     
  2461.     *-- ok. Now we create the popup ...
  2462.     cMove = fseek(nHandle,0,0)
  2463.     nBar = 1
  2464.     define popup pFile from 1,1
  2465.     do while .not. feof(nHandle)
  2466.         cBar = trim(fgets(nHandle))
  2467.         cBar = space(2)+substr(cBar,at(":",cBar)-1)+space(5)
  2468.         define bar nBar of pFile prompt cBar
  2469.         nBar = nBar + 1
  2470.     enddo
  2471.     
  2472.     *-- what do we do with it?
  2473.     clear
  2474.     on selection popup pFile deactivate popup
  2475.     activate popup pFile
  2476.     cSelect = iif(.not. isblank(prompt()), ltrim(rtrim(prompt())),"")
  2477.     
  2478.     *-- cleanup
  2479.     release popup pFile
  2480.     lClose = fclose(nHandle)
  2481.     erase temp.xxx
  2482.     set directory to &cCurDir.
  2483.     restore screen from sFF
  2484.     release screen sFF
  2485.     
  2486. RETURN cSelect
  2487. *-- EoF: FF()
  2488.  
  2489. FUNCTION MakeStr
  2490. *-------------------------------------------------------------------------------
  2491. *-- Programmer..: Angus Scott-Fleming CIS: 75500,3223) 
  2492. *--               (from code published in DBA)
  2493. *-- Date........: 11/25/1992
  2494. *-- Notes.......: Creates an empty structure extended database
  2495. *-- Written for.: dBASE IV 1.5+
  2496. *-- Rev. History: 11/25/1992 - Rev A uses structure of currently open 
  2497. *--                 database, if present
  2498. *-- Calls.......: None
  2499. *-- Called by...: Any
  2500. *-- Usage.......: MakeStr(<cFileName.Ext>)
  2501. *-- Example.....: lDummy = MakeStr("G_HELP.STR")
  2502. *-- Returns.....: .F. if no file was created, .T. if one was
  2503. *-- Parameters..: cFileName = Name of file to create
  2504. *-------------------------------------------------------------------------------
  2505.  
  2506.   parameters cFileName
  2507.   private ALL
  2508.  
  2509.   if isblank(cFileName)
  2510.     return .F.
  2511.   endif
  2512.  
  2513.   if .not. isblank(alias())
  2514.     copy structure extended to &cFileName.
  2515.   else
  2516.     * code from DataBased Advisor to create an empty DBF
  2517.     nLoopCount = 1  && Loop counter
  2518.     nDim       = 5  && Number of rows in the DBF structure array
  2519.  
  2520.     * Declare array with the structure of the "structure extended"
  2521.     * DBF file
  2522.     DECLARE aDbfStru[nDim,5]
  2523.  
  2524.     aDbfStru[1,1] = "FIELD_NAME"   && field name
  2525.     aDbfStru[1,2] = "C"            && field type
  2526.     aDbfStru[1,3] = 10             && field length
  2527.     aDbfStru[1,4] = 0              && number of decimal places
  2528.     aDbfStru[1,5] = "N"            && MDX index tag
  2529.  
  2530.     aDbfStru[2,1] = "FIELD_TYPE"
  2531.     aDbfStru[2,2] = "C"
  2532.     aDbfStru[2,3] =  1
  2533.     aDbfStru[2,4] =  0
  2534.     aDbfStru[2,5] = "N"
  2535.  
  2536.     aDbfStru[3,1] = "FIELD_LEN"
  2537.     aDbfStru[3,2] = "N"
  2538.     aDbfStru[3,3] = 3
  2539.     aDbfStru[3,4] = 0
  2540.     aDbfStru[3,5] = "N"
  2541.  
  2542.     aDbfStru[4,1] = "FIELD_DEC"
  2543.     aDbfStru[4,2] = "N"
  2544.     aDbfStru[4,3] = 3
  2545.     aDbfStru[4,4] = 0
  2546.     aDbfStru[4,5] = "N"
  2547.  
  2548.     aDbfStru[5,1] = "FIELD_IDX"
  2549.     aDbfStru[5,2] = "C"
  2550.     aDbfStru[5,3] = 1
  2551.     aDbfStru[5,4] = 0
  2552.     aDbfStru[5,5] = "N"
  2553.  
  2554.     * Redirect printer output to a file
  2555.     SET PRINTER TO FILE (cFileName)
  2556.     SET PRINT ON
  2557.  
  2558.     * Write DBF file header
  2559.     * First byte (byte 0)- DBF file indicator
  2560.     ??? '{3}'
  2561.  
  2562.     * Creation date - bytes 1-3
  2563.     ??? CHR(VAL(RIGHT(STR(YEAR(DATE())),2))) + ;
  2564.         CHR(MONTH(DATE())) + CHR(DAY(DATE()))
  2565.  
  2566.     * Number of records in the file (zero) - bytes 1-3
  2567.     ??? REPLICATE('{0}',4)
  2568.  
  2569.     * Number of bytes in the header - bytes 8-9
  2570.     ??? '{193}{0}'
  2571.  
  2572.     * Number of bytes in the record (19) - bytes 10-11
  2573.     ??? '{19}{0}'
  2574.  
  2575.     * Bytes 12-31 of the header - not used here
  2576.     * Some appear to have constant value
  2577.     ??? REPLICATE('{0}',18)
  2578.     ??? '{57}{1}'
  2579.  
  2580.     * Field descriptor bytes - looping through the array
  2581.     * nDim times (5 in this case)
  2582.     * Field descriptors are each 32 bytes long
  2583.     DO WHILE nLoopCount <= nDim
  2584.  
  2585.       * Field name - bytes 0-10
  2586.       ??? aDbfStru[nLoopCount,1] +;
  2587.           REPLICATE('{0}', 11-LEN(TRIM(aDbfStru[nLoopCount,1])))
  2588.  
  2589.       * Field type - byte 11
  2590.       ??? aDbfStru[nLoopCount,2]
  2591.  
  2592.       * Bytes 12-15 - not used here
  2593.       ??? REPLICATE('{0}',2)
  2594.       ??? '{238}{85}'
  2595.  
  2596.       * Field length - byte 16
  2597.       ??? CHR(aDbfStru[nLoopCount,3])
  2598.  
  2599.       * Field decimal count - byte 17
  2600.       ??? IIF(aDbfStru[nLoopCount,4] > 0, ;
  2601.             CHR(aDbfStru[nLoopCount,4]), '{0}')
  2602.  
  2603.       * Bytes 18-19 - reserved
  2604.       ??? REPLICATE('{0}',2)
  2605.  
  2606.       * Byte 20 - work area ID.  Let's use 1 for simplicity
  2607.       ??? '{1}'
  2608.  
  2609.       * Bytes 21-31 - MDX index tag flag and reserved bytes
  2610.       ??? IIF(aDbfStru[nLoopCount,5] $ 'YyTt', '{1}', '{0}')
  2611.       ??? REPLICATE('{0}',10)
  2612.  
  2613.       * Increment loop counter
  2614.       nLoopCount = nLoopCount + 1
  2615.     ENDDO
  2616.  
  2617.     * DBF file header terminator and EOF character - byte n+1
  2618.     ??? '{13}{26}'
  2619.  
  2620.     SET PRINTER TO
  2621.     SET PRINT OFF
  2622.   endif
  2623.   select (select())
  2624.   use &cFileName. exclusive
  2625.   zap
  2626.  
  2627. RETURN .T.
  2628. *-- EoF: MakeStr()
  2629.  
  2630. FUNCTION RecChged
  2631. *-------------------------------------------------------------------------------
  2632. *-- Programmer..: Angus Scott-Fleming
  2633. *-- Date........: 11/25/1992
  2634. *-- Notes.......: Test field values against memory variables to see if an
  2635. *--               on-screen display has changed from the disk-record
  2636. *--               CHANGE() requires the existence of field _DBASELOCK
  2637. *--               whereas RecChged does not.
  2638. *-- Written for.: dBASE IV 1.1+
  2639. *-- Rev. History: 11/25/1992  for dBase IV 1.5
  2640. *--               10/08/1992  don't test memo-fields
  2641. *--               06/09/1992  dropped PCount() for 4.11 use
  2642. *--               06/04/1992  skips any field with REVDATE in its name
  2643. *-- Calls.......: FldCount() (1.1)
  2644. *--               ExEqual()         Function in STRINGS.PRG
  2645. *-- Called by...: Any
  2646. *-- Usage.......: RecChged(<cTable_Name>)
  2647. *-- Example.....: if RecChged("mpl") .and. Confirm("Save?",.Y.)
  2648. *-- Returns.....: .T. = record has changed  .F. = record has not changed
  2649. *-- Parameters..: cTable_Name = (OPTIONAL) alias of table to test
  2650. *-------------------------------------------------------------------------------
  2651.  
  2652.     parameters ctable_name
  2653.     if empty(ctable_name)
  2654.       ctable_name = alias()
  2655.     endif
  2656.     n = 1
  2657.     do while n <= fldcount(ctable_name)
  2658.       test_field = field(n,ctable_name)
  2659.       test_disk = "&ctable_name->&test_field"
  2660.       * Thu  06-04-1992  don't test _DBASELOCK or REVDATE fields,
  2661.       *                  since they're changed automagically
  2662.       * if .not. ExEqual(upper(test_field),"_DBASELOCK")
  2663.       * Thu  10-08-1992  check for existence of the field in the table
  2664.       *                  skip check for memo fields
  2665.       if .not. type("&test_disk") $ "MU" .and. .not. type("m->&test_field") ="U"
  2666.         if .not. upper(test_field) = "_DBASELOCK" ;
  2667.            .and. .not.("REVDATE"$test_field)
  2668.           if .not. ExEqual(m->&test_field,&test_disk)
  2669.             return .T.
  2670.           endif
  2671.         endif
  2672.       endif
  2673.       n = n + 1
  2674.     enddo
  2675.  
  2676. RETURN .F.
  2677. *-- EoF: RecChged()
  2678.  
  2679. FUNCTION CopyFile
  2680. *-------------------------------------------------------------------------------
  2681. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  2682. *-- Date........: 04/26/1993
  2683. *-- Notes.......: Copies a database plus its production index (if it has one),
  2684. *--               and the DBT file if it exists as well.
  2685. *--               Use this instead of the COPY TO... WITH PRODUCTION command.
  2686. *--               Because it uses the COPY FILE command (a file-to-file copy)
  2687. *--               instead of the COPY TO command (a record-by-record copy),
  2688. *--               this is much faster.
  2689. *--               The DBF must be closed when you use this UDF.
  2690. *-- Written for.: dBASE IV, 1.5
  2691. *-- Rev. History: 04/26/1993  -- Original
  2692. *-- Calls.......: MdxPoint()           Function in FILES.PRG
  2693. *--               DbfName()            Function in FILES.PRG
  2694. *-- Called by...: Any
  2695. *-- Usage.......: CopyFile("<cOldFile>","<cNewFile>")
  2696. *-- Example.....: CopyFile("FRED","MARY")
  2697. *-- Returns.....: nError - 0 if copy operation worked okay.
  2698. *--                        1 if file to be copied didn't exist.
  2699. *-- Parameters..: cOldFile - DBF file to be copied
  2700. *--               cNewFile - Name for copy of DBF
  2701. *-------------------------------------------------------------------------------
  2702.  
  2703.         parameters cOldFile,cNewFile
  2704.         private cOldFile, cNewFile, lOpen, nRec, cTag, cAlias, nError
  2705.  
  2706.         nError = 0
  2707.  
  2708.         *-- Check if database actually exists
  2709.         if file(cOldFile + ".DBF")
  2710.  
  2711.            *-- Copy the file
  2712.            copy file cOldFile + ".DBF" to cNewFile + ".DBF"
  2713.  
  2714.            *-- Copy its MDX file
  2715.            if file(cOldFile + ".MDX")
  2716.  
  2717.               copy file cOldFile + ".MDX" to cNewFile + ".MDX"
  2718.               *-- Update the hard-coded database reference in the MDX header
  2719.               xJunk = MdxPoint(cNewFile)
  2720.  
  2721.            endif
  2722.  
  2723.            *-- Copy its memo file
  2724.            if file(cOldFile + ".DBT")
  2725.  
  2726.               copy file cOldFile + ".DBT" to cNewFile + ".DBT"
  2727.  
  2728.            endif
  2729.  
  2730.         else
  2731.            nError = 1
  2732.  
  2733.         endif
  2734.  
  2735. RETURN (nError)
  2736. *-- EoF: CopyFile()
  2737.  
  2738. FUNCTION CopyFil1
  2739. *-------------------------------------------------------------------------------
  2740. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  2741. *-- Date........: 04/26/1993
  2742. *-- Notes.......: Copies a database plus its production index (if it has one),
  2743. *--               and the DBT file if it exists as well.
  2744. *--               Based on CopyFile().
  2745. *--               With this version, it doesn't matter whether the file
  2746. *--               you're copying is open or closed. If it's open, the:
  2747. *--
  2748. *--               * current index order
  2749. *--               * alias
  2750. *--               * record pointer
  2751. *--
  2752. *--               will all be retained.
  2753. *--               You must SET DBTRAP OFF before calling this routine from
  2754. *--               a program or the dot prompt.
  2755. *-- Written for.: dBASE IV, 1.5
  2756. *-- Rev. History: 04/26/1993  -- Original
  2757. *-- Calls.......: MdxPoint()           Function in FILES.PRG
  2758. *--               DbfName()            Function in FILES.PRG
  2759. *-- Called by...: Any
  2760. *-- Usage.......: CopyFile("<cOldFile>","<cNewFile>")
  2761. *-- Example.....: CopyFile("FRED","MARY")
  2762. *-- Returns.....: nError - 0 if copy operation worked okay.
  2763. *--                        1 if file to be copied didn't exist.
  2764. *-- Parameters..: cOldFile - DBF file to be copied
  2765. *--               cNewFile - Name for copy of DBF
  2766. *-------------------------------------------------------------------------------
  2767.  
  2768.         parameters cOldFile,cNewFile
  2769.         private cOldFile, cNewFile, lOpen, nRec, cTag, cAlias, nError
  2770.  
  2771.         lOpen  = .F.
  2772.         nError = 0
  2773.  
  2774.         *-- Check whether database exists
  2775.         if file(cOldFile + ".DBF")
  2776.  
  2777.            *-- If database is currently open, save info about it
  2778.            if DbfName() = upper(cOldFile)
  2779.               nRec   = recno()
  2780.               cTag   = tag()
  2781.               cAlias = alias()
  2782.               lOpen  = .T.
  2783.               use
  2784.            endif
  2785.  
  2786.            *-- Copy the database
  2787.            copy file cOldFile + ".DBF" to cNewFile + ".DBF"
  2788.  
  2789.            *-- Copy its MDX
  2790.            if file(cOldFile + ".MDX")
  2791.  
  2792.               copy file cOldFile + ".MDX" to cNewFile + ".MDX"
  2793.               *-- Update the hard-coded database reference in the MDX header
  2794.               xJunk = MdxPoint(cNewFile)
  2795.  
  2796.            endif
  2797.  
  2798.            *-- Copy its memo file
  2799.            if file(cOldFile + ".DBT")
  2800.  
  2801.               copy file cOldFile + ".DBT" to cNewFile + ".DBT"
  2802.  
  2803.            endif
  2804.  
  2805.            *-- If file was originally open, reopen it and restore its state
  2806.            if lOpen
  2807.               use (cOldFile) ALIAS &cAlias
  2808.               if "" <> cTag
  2809.                  set order to (cTag)
  2810.               endif
  2811.               go nRec
  2812.            endif
  2813.  
  2814.         else
  2815.            nError = 1
  2816.  
  2817.         endif
  2818.  
  2819. RETURN (nError)
  2820. *-- EoF: CopyFil1()
  2821.  
  2822. FUNCTION RenFile
  2823. *-------------------------------------------------------------------------------
  2824. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  2825. *-- Date........: 04/26/1993
  2826. *-- Notes.......: Renames a .DBF file and its production index and
  2827. *--               memo files (if they exist) and correctly updates
  2828. *--               the .MDX header.
  2829. *--               The DBF must be closed before using this UDF.
  2830. *-- Written for.: dBASE IV, 1.5
  2831. *-- Rev. History: 04/26/1993  -- Original
  2832. *-- Calls.......: MdxPoint()           Function in FILES.PRG
  2833. *--               DbfName()            Function in FILES.PRG
  2834. *-- Called by...: Any
  2835. *-- Usage.......: RenFile("<cOldFile>","<cNewFile>")
  2836. *-- Example.....: RenFile("FRED","MARY")
  2837. *-- Returns.....: nError   - 0 if renaming operation went okay.
  2838. *--                          1 if file to be renamed didn't exist.
  2839. *-- Parameters..: cOldFile - Current database name
  2840. *--               cNewFile - New name for database
  2841. *-------------------------------------------------------------------------------
  2842.  
  2843.         parameters cOldFile,cNewFile
  2844.         private cOldFile, cNewFile, lOpen, nError, nRec, cTag, cAlias, xJunk
  2845.  
  2846.         nError = 0
  2847.  
  2848.         *-- Check whether database exists
  2849.         if file(cOldFile + ".DBF")
  2850.  
  2851.            *--  Rename it
  2852.            rename cOldFile + ".DBF" to cNewFile + ".DBF"
  2853.  
  2854.            *-- Rename its MDX
  2855.            if file(cOldFile + ".MDX")
  2856.  
  2857.               rename cOldFile + ".MDX" to cNewFile + ".MDX"
  2858.               *-- Update the hard-coded database reference in the MDX header
  2859.               xJunk = MdxPoint(cNewFile)
  2860.  
  2861.            endif
  2862.  
  2863.            *-- Rename its memo file
  2864.            if file(cOldFile + ".DBT")
  2865.  
  2866.               rename cOldFile + ".DBT" to cNewFile + ".DBT"
  2867.  
  2868.            endif
  2869.  
  2870.         else
  2871.            nError = 1
  2872.  
  2873.         endif
  2874.  
  2875. RETURN (nError)
  2876. *-- EoF: RenFile()
  2877.  
  2878. FUNCTION RenFile1
  2879. *-------------------------------------------------------------------------------
  2880. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  2881. *-- Date........: 04/26/1993
  2882. *-- Notes.......: Renames a .DBF file and its production index and
  2883. *--               memo files (if they exist) and correctly updates
  2884. *--               the .MDX header.
  2885. *--               This is a variant of RenFile().
  2886. *--               In this version, it doesn't matter whether the database
  2887. *--               is open or closed when you call the UDF. If it is open, the
  2888. *--
  2889. *--               * current index order
  2890. *--               * record pointer
  2891. *--
  2892. *--               will be restored after the renaming.
  2893. *--               You must SET DBTRAP OFF before calling this UDF.
  2894. *-- Written for.: dBASE IV, 1.5
  2895. *-- Rev. History: 04/26/1993  -- Original
  2896. *-- Calls.......: MdxPoint()           Function in FILES.PRG
  2897. *--               DbfName()            Function in FILES.PRG
  2898. *-- Called by...: Any
  2899. *-- Usage.......: RenFile("<cOldFile>","<cNewFile>")
  2900. *-- Example.....: RenFile("FRED","MARY")
  2901. *-- Returns.....: nError   - 0 if renaming operation went okay.
  2902. *--                          1 if file to be renamed didn't exist.
  2903. *-- Parameters..: cOldFile - Current database name
  2904. *--               cNewFile - New name for database
  2905. *-------------------------------------------------------------------------------
  2906.  
  2907.         parameters cOldFile,cNewFile
  2908.         private cOldFile, cNewFile, lOpen, nError, nRec, cTag, xJunk
  2909.  
  2910.         lOpen  = .F.
  2911.         nError = 0
  2912.  
  2913.         *-- Check if database exists
  2914.         if file(cOldFile + ".DBF")
  2915.  
  2916.            *-- If database is currently open, save record pointer
  2917.            *-- and index order
  2918.            if DbfName() = upper(cOldFile)
  2919.               nRec   = recno()
  2920.               cTag   = tag()
  2921.               lOpen  = .T.
  2922.               use
  2923.            endif
  2924.  
  2925.            *-- Rename database
  2926.            rename cOldFile + ".DBF" to cNewFile + ".DBF"
  2927.  
  2928.            *-- Rename its MDX
  2929.            if file(cOldFile + ".MDX")
  2930.  
  2931.               rename cOldFile + ".MDX" to cNewFile + ".MDX"
  2932.               *-- Update the hard-coded database reference in the MDX header
  2933.               xJunk = MdxPoint(cNewFile)
  2934.  
  2935.            endif
  2936.  
  2937.            *-- Rename its memo file
  2938.            if file(cOldFile + ".DBT")
  2939.  
  2940.               rename cOldFile + ".DBT" to cNewFile + ".DBT"
  2941.  
  2942.            endif
  2943.  
  2944.            *-- If file was originally open, reopen it and restore its state
  2945.            if lOpen
  2946.               use (cNewFile)
  2947.               if "" <> cTag
  2948.                  set order to (cTag)
  2949.               endif
  2950.               go nRec
  2951.            endif
  2952.  
  2953.         else
  2954.            nError = 1
  2955.  
  2956.         endif
  2957.  
  2958. RETURN (nError)
  2959. *-- EoF: RenFile1()
  2960.  
  2961. FUNCTION DelFile
  2962. *-------------------------------------------------------------------------------
  2963. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  2964. *-- Date........: 04/26/1993
  2965. *-- Notes.......: Deletes a database, its production index and its memo
  2966. *--               file (if there is one) in one fell swoop.
  2967. *-- Written for.: dBASE IV, 1.5
  2968. *-- Rev. History: 04/26/1993  -- Original
  2969. *-- Calls.......: None
  2970. *-- Called by...: Any
  2971. *-- Usage.......: DelFile("<cDbfName>")
  2972. *-- Example.....: DelFile("FRED")
  2973. *-- Returns.....: nError    - 0 if file deletion went okay
  2974. *--                         - 1 if file to be deleted didn't exist.
  2975. *-- Parameters..: cDbfName  - Name of the database you wish to delete.
  2976. *-------------------------------------------------------------------------------
  2977.         parameters cDbfName
  2978.         private cDbfName, cMdxName, cDbtName, nError
  2979.  
  2980.         cMdxName  = cDbfName + ".MDX"
  2981.         cDbtName  = cDbfName + ".DBT"
  2982.         cDbfName  = cDbfName + ".DBF"
  2983.         nError    = 0
  2984.  
  2985.         *-- Check database exists
  2986.         if file(cDbfName)
  2987.  
  2988.            *-- Delete database
  2989.            delete file (cDbfName)
  2990.  
  2991.            *-- Delete its MDX
  2992.            if file(cMdxName)
  2993.               delete file (cMdxName)
  2994.            endif
  2995.  
  2996.            *-- Delete its memo file if any
  2997.            if file(cDbtName)
  2998.               delete file (cDbtName)
  2999.            endif
  3000.  
  3001.         else
  3002.  
  3003.            nError = 1
  3004.  
  3005.         endif
  3006.  
  3007. RETURN (nError)
  3008. *-- EoF: DelFile()
  3009.  
  3010. FUNCTION DelMdx
  3011. *-------------------------------------------------------------------------------
  3012. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3013. *-- Date........: 04/26/1993
  3014. *-- Notes.......: Deletes a production index file, correctly updating
  3015. *--               the production index byte in the DBF header, so you
  3016. *--               avoid getting the "Production index not found" message.
  3017. *-- Written for.: dBASE IV, 1.5
  3018. *-- Rev. History: 04/26/1993  -- Original
  3019. *-- Calls.......: None
  3020. *-- Called by...: Any
  3021. *-- Usage.......: DelMdx("<cMdx>")
  3022. *-- Example.....: DelMdx("fred")
  3023. *-- Returns.....: nError  =  0 if deletion is okay
  3024. *--                          1 if file doesn't exist
  3025. *-- Parameters..: cMdx = Production MDX file to delete
  3026. *-------------------------------------------------------------------------------
  3027.         parameters cMdx
  3028.         private cMdx, cMdxName, cDbfName, nHandle, nError, xJunk
  3029.  
  3030.  
  3031.         cMdxName = cMdx + ".MDX"
  3032.         cDbfName = cMdx + ".DBF"
  3033.         nError   = 0
  3034.  
  3035.         *-- Check if file exists
  3036.         if file(cMdxName)
  3037.  
  3038.            *-- Delete MDX file
  3039.            delete file (cMdxName)
  3040.  
  3041.            *-- Update MDX byte in DBF header, indicating there is no longer
  3042.            *-- an MDX for this database.
  3043.            nHandle = fopen((cDbfName),"rw")
  3044.            xJunk   = fseek(nHandle,28,0)
  3045.            xJunk   = fwrite(nHandle,chr(0))
  3046.            xJunk   = fclose(nHandle)
  3047.  
  3048.         else
  3049.  
  3050.            nError = 1
  3051.  
  3052.         endif
  3053.  
  3054. RETURN ("")
  3055. *-- EoF: DelMdx()
  3056.  
  3057. FUNCTION RestMdx
  3058. *-------------------------------------------------------------------------------
  3059. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3060. *-- Date........: 04/26/1993
  3061. *-- Notes.......: Restores a pointer to an (existing) production MDX file
  3062. *--               in the DBF header. Only really needed if you make a
  3063. *--               mess using the DelMdx() function.
  3064. *-- Written for.: dBASE IV, 1.5
  3065. *-- Rev. History: 04/26/1993  -- Original
  3066. *-- Calls.......: None
  3067. *-- Called by...: Any
  3068. *-- Usage.......: RestMdx("<cMdx>")
  3069. *-- Example.....: RestMdx("FRED")
  3070. *-- Returns.....: nError  - 0 if pointer restoration went okay
  3071. *--                         1 if the MDX didn't exist
  3072. *-- Parameters..: cMdx    - MDX/DBF file name.
  3073. *-------------------------------------------------------------------------------
  3074.  
  3075.         parameters cMdx
  3076.         private cMdxName, cDbfName, nHandle, xJunk, nError
  3077.  
  3078.         cMdxName = cMdx + ".MDX"
  3079.         cDbfName = cMdx + ".DBF"
  3080.  
  3081.         if file(cMdxName)
  3082.  
  3083.            *-- Update MDX byte in DBF header, indicating there is an
  3084.            *-- MDX for this database.
  3085.            nHandle = fopen((cDbfName),"rw")
  3086.            xJunk   = fseek(nHandle,28,0)
  3087.            xJunk   = fwrite(nHandle,chr(1))
  3088.            xJunk   = fclose(nHandle)
  3089.            nError  = 0
  3090.  
  3091.         else
  3092.  
  3093.            nError = 1
  3094.  
  3095.         endif
  3096.  
  3097. RETURN (nError)
  3098. *-- EoF: RestMdx()
  3099.  
  3100. FUNCTION MdxPoint
  3101. *-------------------------------------------------------------------------------
  3102. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3103. *-- Date........: 04/26/1993
  3104. *-- Notes.......: Changes the hard-coded DBF name in an MDX file header
  3105. *--               (either a production or non-production MDX).
  3106. *-- Written for.: dBASE IV, 1.5
  3107. *-- Rev. History: 04/26/1993  -- Original
  3108. *-- Calls.......: None
  3109. *-- Called by...: Any (Specifically CopyFile() and RenFile())
  3110. *-- Usage.......: MdxPoint("<cDbfName>", "<cMdx>")
  3111. *-- Example.....: MdxPoint("FRED")
  3112. *--               MdxPoint("FRED","FULLNAME")
  3113. *-- Returns.....: None
  3114. *-- Parameters..: cDbfName - The name of the DBF to be hard-coded into the
  3115. *--                          MDX header.
  3116. *--               cMdx     - The name of the MDX file, if it's a
  3117. *--                          non-production MDX (omit this parameter
  3118. *--                          completely if it's a production MDX).
  3119. *-------------------------------------------------------------------------------
  3120.  
  3121.         parameters cDbfName, cMdx
  3122.         private nPadl, cDbfName, nHandle, xJunk, n
  3123.  
  3124.         *-- Find out how long the DBF filename is and set padding length
  3125.         nPadl    = 8 - len(cDbfName)
  3126.         cDbfName = upper(cDbfName)
  3127.  
  3128.         *-- Check how many parameters have been passed: 1 means its a
  3129.         *-- production index, 2 is a non-production index
  3130.         if pcount() < 2
  3131.  
  3132.            nHandle = fopen((cDbfName)+".MDX","rw")
  3133.  
  3134.         else
  3135.  
  3136.            nHandle = fopen((cMdx)+".MDX","rw")
  3137.  
  3138.         endif
  3139.  
  3140.         *-- Position file pointer to Byte 4, which is start of hard-coded
  3141.         *-- DBF name in MDX header
  3142.         xJunk   = fseek(nHandle,4,0)
  3143.         *-- Write the new DBF filename into the header
  3144.         xJunk   = fwrite(nHandle,(cDbfName))
  3145.  
  3146.         n = 0
  3147.  
  3148.         do while n < nPadl
  3149.  
  3150.            *-- Pad filename out to 8 characters in header, using nulls
  3151.            xJunk  = fwrite(nHandle,chr(0))
  3152.            n      = n + 1
  3153.  
  3154.         enddo
  3155.  
  3156.         xJunk = fclose(nHandle)
  3157.  
  3158. RETURN ("")
  3159. *-- EoF: MdxPoint()
  3160.  
  3161. FUNCTION DbfName
  3162. *-------------------------------------------------------------------------------
  3163. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3164. *-- Date........: 04/26/1993
  3165. *-- Notes.......: Strips the 8-character DBF filename out of the full
  3166. *--               pathname returned by the dbf() function. Works on the
  3167. *--               database in USE in the current workarea.
  3168. *-- Written for.: dBASE IV, 1.5
  3169. *-- Rev. History: 04/26/1993  -- Original
  3170. *-- Calls.......: None
  3171. *-- Called by...: Any (Specifically CopyFile() and RenFile()).
  3172. *-- Usage.......: DbfName()
  3173. *-- Example.....: DbfName()
  3174. *-- Returns.....: cName   =  8-character filename of DBF.
  3175. *-- Parameters..: None
  3176. *-------------------------------------------------------------------------------
  3177.         private cFullPath, cName
  3178.  
  3179.         cFullPath = set("FULLPATH")
  3180.         set fullpath off
  3181.  
  3182.         *-- Check if a database is open in the current workarea
  3183.         if "" <> dbf()
  3184.  
  3185.            *-- Strip the filename out of the full pathname
  3186.            cName = ( substr( dbf(), 3, at( ".", dbf() ) - 3 ) )
  3187.  
  3188.         else
  3189.  
  3190.            cName = ""
  3191.  
  3192.         endif
  3193.  
  3194.         set fullpath &cFullPath
  3195.  
  3196. RETURN (cName)
  3197. *-- EoF: DbfName()
  3198.  
  3199. FUNCTION MdxGauge
  3200. *-------------------------------------------------------------------------------
  3201. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3202. *-- Date........: 04/26/1993
  3203. *-- Notes.......: Indexes a database, showing a 'fuel-gauge' style progress
  3204. *--               indicator during the process.
  3205. *--               You must SET DBTRAP OFF in the calling routine or at the
  3206. *--               dot prompt.
  3207. *--               This routine slows down indexing, but allows the user to
  3208. *--               know what's going on.
  3209. *-- Written for.: dBASE IV, 1.5
  3210. *-- Rev. History: 04/26/1993  -- Original
  3211. *-- Calls.......: Gauge(), DelGauge()
  3212. *-- Called by...: Any
  3213. *-- Usage.......: MdxGauge("<cDataFile>","<cIndexExp>","<cMTag>","<cMdxName>",;
  3214. *--                        "<cClr>",<nURow>,<nLCol>)
  3215. *-- Example.....: MdxGauge("FRED","upper(LNAME)+upper(FNAME)","FULLNAME","",;
  3216. *--                         0,0)
  3217. *--
  3218. *--               This example indexes FRED.DBF on the uppercase last and
  3219. *--               firstnames, to the production MDX with a tagname of
  3220. *--               FULLNAME. It also uses your current default colour scheme,
  3221. *--               and positions the fuel gauge at 0,0.
  3222. *--
  3223. *--               MdxGauge("FRED","substr(LNAME,5)","SHORTNAME","OTHERS",;
  3224. *--                        "r+/b,r+/b,b+/w";10,15)
  3225. *--
  3226. *--               This example indexes FRED.DBF on the first 5 characters of
  3227. *--               the lastname to a non-production MDX called OTHERS, using
  3228. *--               the tagname SHORTNAME. It sets the colours of the fuel-
  3229. *--               gauge and the fuel-gauge frame, and positions the gauge
  3230. *--               starting at 10,15.
  3231. *-- Returns.....: nError     =  0 if MDX header was updated correctly
  3232. *--                          =  1 if MDX header couldn't be updated
  3233. *-- Parameters..: cDataFile  =  DBF to be indexed
  3234. *--               cMdxExpr   =  Indexing expression
  3235. *--               cMdxTag    =  Index TAG name
  3236. *--               cMdxName   =  MDX name - only needed if using a
  3237. *--                             non-production MDX.
  3238. *--               cClr       =  Colours for fuel gauge. You can include
  3239. *--                             standard, enhanced and frame colours in the
  3240. *--                             string. If you don't include a colour string,
  3241. *--                             the UDF will use the current colours.
  3242. *--               nURow      =  Starting row for the fuel gauge on screen.
  3243. *--                             Must be less than 20 - if not, the program
  3244. *--                             will make nURow = 19.
  3245. *--               nLCol      =  Starting column for the fuel gauge.
  3246. *--                             Must be less than 26 - if not, the program
  3247. *--                             will make nLCol = 25.
  3248. *-------------------------------------------------------------------------------
  3249.  
  3250.         parameters cDbfName, cMdxExpr, cMdxTag, cMdxName, cClr, nURow, nLCol
  3251.         private nBarLen, cBarPad, cIndex, nError, nRecInt, nBarFull
  3252.  
  3253.         use &cDbfName
  3254.  
  3255.         cStatus = set("STATUS")
  3256.         cSafety = set("SAFETY")
  3257.         cTalk   = set("TALK")
  3258.         set status off
  3259.         set safety off
  3260.         set talk off
  3261.  
  3262.         cMdxExpr  = upper(cMdxExpr)
  3263.         cMdxTag   = upper(cMdxTag)
  3264.  
  3265.         *-- If colour parameter is blank, use default colour scheme
  3266.         if cClr <> ""
  3267.  
  3268.            cClr = SET("ATTR")
  3269.  
  3270.         endif
  3271.  
  3272.  
  3273.         if nURow > 19
  3274.  
  3275.            nURow = 19
  3276.  
  3277.         endif
  3278.  
  3279.         if nLCol > 25
  3280.  
  3281.            nLCol = 25
  3282.  
  3283.         endif
  3284.  
  3285.         *-- Determine width of fuel-gauge
  3286.         if reccount() > 50
  3287.  
  3288.            nRecInt   = int(reccount()/50)
  3289.            nBarLen   = int( reccount() / nRecInt )
  3290.  
  3291.         else
  3292.  
  3293.            nBarLen   = reccount() + 1
  3294.  
  3295.         endif
  3296.  
  3297.         cBarPad = space(round((nBarLen-16)/3,0))
  3298.  
  3299.         clear
  3300.  
  3301.         *-- Display fuel-gauge window and empty gauge
  3302.         define window wGauge from nURow, nLCol;
  3303.                 to nURow+5,nBarLen+nLCol+2 color &cClr
  3304.         activate window wGauge
  3305.  
  3306.         @ 0,0 say "Indexing " + Dbf()
  3307.         @ 1,0 say "0%  " + cBarPad + "25% " + cBarPad + "75% " + ;
  3308.                    cBarPad + "100%"
  3309.         @ 2,0 say replicate( chr(219), nBarlen )
  3310.         @ 2,0 say ""
  3311.  
  3312.         *-- Check if it's a production index or not, and then
  3313.         *-- use the appropriate index expression. The FOR condition
  3314.         *-- in the expression "fills up" the fuel gauge.
  3315.         if "" = cMdxName
  3316.  
  3317.            index on &cMdxExpr tag &cMdxTag for Gauge()
  3318.  
  3319.         else
  3320.            index on &cMdxExpr tag &cMdxTag of &cMdxName for Gauge()
  3321.  
  3322.         endif
  3323.  
  3324.         *-- Clean up
  3325.         clear
  3326.         @ 2,0 say "Closing files..."
  3327.         nError  =  0
  3328.         cIndex  = mdx()
  3329.         use
  3330.  
  3331.         *-- Call UDF to delete reference to Gauge() UDF from MDX header
  3332.         nError = DelGauge(cIndex, cMdxTag)
  3333.  
  3334.         deactivate window wGauge
  3335.  
  3336.         set status &cStatus
  3337.         set safety &cSafety
  3338.         set talk &cTalk
  3339.  
  3340. RETURN(nError)
  3341. *-- EoF: MdxGauge()
  3342.  
  3343. FUNCTION Gauge
  3344. *-------------------------------------------------------------------------------
  3345. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3346. *-- Date........: 04/26/1993
  3347. *-- Notes.......: Routine used by MdxGauge() to "fill up" the fuel-gauge
  3348. *--               on screen during indexing.
  3349. *--               It is called from an indexing "FOR" expression, and always
  3350. *--               returns .T. to include all records in the index.
  3351. *-- Written for.: dBASE IV, 1.5
  3352. *-- Rev. History: 04/26/1993  -- Original
  3353. *-- Calls.......: None
  3354. *-- Called by...: MdxGauge()           Function in FILES.PRG
  3355. *-- Usage.......: Gauge()
  3356. *-- Example.....: Gauge()
  3357. *-- Returns.....: .T.
  3358. *-- Parameters..: None
  3359. *-------------------------------------------------------------------------------
  3360.  
  3361.         *-- Every time 2% of the file or so is indexed...
  3362.         if reccount() > 50
  3363.  
  3364.            if mod( recno(), nRecInt ) = 0
  3365.  
  3366.               *-- Display a solid bar character to "fill up" the gauge
  3367.               ?? chr(177)
  3368.  
  3369.            endif
  3370.  
  3371.         else
  3372.  
  3373.            ?? chr(177)
  3374.  
  3375.         endif
  3376.  
  3377. RETURN(.T.)
  3378. *-- EoF: Gauge()
  3379.  
  3380. FUNCTION DelGauge
  3381. *-------------------------------------------------------------------------------
  3382. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3383. *-- Date........: 04/26/1993
  3384. *-- Notes.......: Deletes all reference to the Gauge() UDF from within
  3385. *--               an MDX header file.
  3386. *-- Written for.: dBASE IV, 1.5
  3387. *-- Rev. History: 04/26/1993  -- Original
  3388. *-- Calls.......: FindTagExp()         Function in FILES.PRG
  3389. *-- Called by...: MdxGauge()
  3390. *-- Usage.......: DelGauge("<cMdx>","<cTag>")
  3391. *-- Example.....: DelGauge("FRED","upper(LASTNAME)+upper(FIRSTNAME)")
  3392. *-- Returns.....: nError  -  Error code.
  3393. *--                          0 if the UDF managed to delete the Gauge()
  3394. *--                          reference in the header.
  3395. *--                          1 if the UDF failed (it couldn't find the
  3396. *--                          Gauge() reference.
  3397. *-- Parameters..: cMdx  =  MDX file to search.
  3398. *--               cTag  =  TAG expression to search for.
  3399. *-------------------------------------------------------------------------------
  3400.         parameters cMdx, cTag
  3401.         private nHandle, nTagExp, nForFlag, nForExp, nError, n, xJunk
  3402.  
  3403.         *-- Open the MDX file
  3404.         nHandle = fopen(cMdx,'rw')
  3405.  
  3406.         *-- Find the information about the TAG in the MDX header
  3407.         nTagExp  = FindTagExp( nHandle, cTag )
  3408.         *-- Find the byte indicating whether a FOR clause was used
  3409.         *-- to create this particular TAG.
  3410.         nForFlag = nTagExp + 245
  3411.         *-- Find the start of the FOR expression in the TAG information
  3412.         nForExp  = nTagExp + 762
  3413.  
  3414.         *-- Place 00H in the byte indicating a FOR clause, to delete
  3415.         *-- reference to the FOR clause.
  3416.         xJunk    = fseek( nHandle, nForFlag, 0 )
  3417.         xJunk    = fwrite (nHandle, chr(0))
  3418.         *-- Positioning the pointer at the FOR clause in the TAG info.
  3419.         xJunk    = fseek( nHandle, nForExp, 0 )
  3420.  
  3421.         *-- Check that we've found our UDF reference in the FOR clause
  3422.         *-- and, if so, delete the reference to the UDF by writing a
  3423.         *-- series of nulls to the file over the word "GAUGE()".
  3424.         if upper(fread(nHandle,7)) = 'GAUGE()'
  3425.  
  3426.            nError  = 0
  3427.            xJunk  = fseek( nHandle, nForExp, 0)
  3428.            n      = 1
  3429.  
  3430.            do while n < 8
  3431.  
  3432.               xJunk  = fwrite(nHandle,chr(0))
  3433.               n      = n + 1
  3434.  
  3435.            enddo
  3436.  
  3437.         else
  3438.  
  3439.            nError = 1
  3440.  
  3441.         endif
  3442.  
  3443.         xJunk = Fclose(nHandle)
  3444.  
  3445. RETURN (nError)
  3446. *-- EoF: DelGauge()
  3447.  
  3448. FUNCTION FindTagExp
  3449. *-------------------------------------------------------------------------------
  3450. *-- Programmer..: Rose Vines (CIS: 100026,3153) (dBase version)
  3451. *-- Date........: 04/26/1993
  3452. *-- Notes.......: Finds the starting position of a specific index TAG
  3453. *--               expression within an MDX header.
  3454. *-- Written for.: dBASE IV, 1.5
  3455. *-- Rev. History: 04/26/1993  -- Original
  3456. *-- Calls.......: FLocate()            Function in FILES.PRG
  3457. *--               FReadI32()           Function in FILES.PRG
  3458. *-- Called by...: DelGauge()
  3459. *-- Usage.......: FindTagExp(<nHandle>,"<cMdxTag>")
  3460. *-- Example.....: FindTagExp( 5, "upper(LASTNAME)+upper(FIRSTNAME)" )
  3461. *-- Returns.....: nTagExp   -  Starting position of the TAG expression
  3462. *--                            within the MDX header file.
  3463. *-- Parameters..: nHandle  =  DOS file handle of an MDX file.
  3464. *--               cMdxTag  =  MDX TAG expression.
  3465. *-------------------------------------------------------------------------------
  3466.  
  3467.         parameters nHandle, cMdxTag
  3468.         private nJunk, nPos, nPoint, nTagExp
  3469.  
  3470.         *-- Shift pointer to byte 512 in the MDX file. At byte 512,
  3471.         *-- there's an array of TAG names.
  3472.         nJunk   = fseek( nHandle, 512, 0 )
  3473.         *-- From there, locate our particular TAG in the array
  3474.         nPos    = Flocate( nHandle, cMdxTag, .T. )
  3475.         *-- Back up and read the preceding 4 bytes, which are a pointer
  3476.         *-- to the file offset where the information about our TAG
  3477.         *-- is located in the MDX file.
  3478.         nJunk   = fseek( nHandle, nPos - 4 )
  3479.         *-- Convert the 4-byte pointer to decimal
  3480.         nPoint  = FreadI32( nHandle )
  3481.         *-- Return the starting position of the TAG info.
  3482.         nTagExp = fseek( nHandle, nPoint * 512 )
  3483.  
  3484. RETURN( nTagExp )
  3485. *-- EoF:  FindTagExp()
  3486.  
  3487. FUNCTION FLocate
  3488. *-------------------------------------------------------------------------------
  3489. *-- Programmer..: Rose Vines (CIS: 100026,3153) (dBase version)
  3490. *--               Matt Whelan (Clipper version - not included here)
  3491. *-- Date........: 04/26/1993
  3492. *-- Notes.......: Finds a string within a file, starting from the current
  3493. *--               position of the file pointer (Operates using low-level
  3494. *--               file functions).
  3495. *--               Due to the 254-character limitation on dBase string
  3496. *--               variables, this is not particularly fast on large files as
  3497. *--               it must search through a 254-character buffer.
  3498. *--               The Clipper version, which uses a 65,535-character buffer,
  3499. *--               is much faster.
  3500. *-- Written for.: dBASE IV, 1.5
  3501. *-- Rev. History: 04/26/1993  -- Original
  3502. *-- Calls.......: FTell()              Function in FILES.PRG
  3503. *--               FLen()               Function in FILES.PRG
  3504. *-- Called by...: Any (Specifically FindTaxExp()).
  3505. *-- Usage.......: FLocate(<nHandle>,"<cSearch>",<lWantUpper>)
  3506. *-- Example.....: FLocate( 5, "Crabapple Cove", .T.)
  3507. *-- Returns.....: nFoundPos  -  Starting position of the string in the file
  3508. *-- Parameters..: nHandle     =  DOS file handle
  3509. *--               cSearch     =  Search string
  3510. *--               lWantUpper  =  Whether you want the search string first
  3511. *--                              converted to uppercase.
  3512. *-------------------------------------------------------------------------------
  3513.  
  3514.         parameters nHandle, cSearch, lWantUpper
  3515.         private cBuffer, nCurPos, nStartPos, nBuffSize, nFlength
  3516.         private nBufPos, cTxtBuff, nBuffOffset, nFoundPos, cAddBuf
  3517.  
  3518.         nFoundPos  = -2
  3519.  
  3520.         *-- Convert search string to uppercase if required
  3521.         if pcount() = 2
  3522.  
  3523.            lWantUpper = .F.
  3524.  
  3525.         endif
  3526.  
  3527.         *-- If a valid file handle has been passed...
  3528.         if nHandle > 0
  3529.  
  3530.               *-- Store our current position in the file,
  3531.               *-- check the file length and then determine the
  3532.               *-- buffer size.
  3533.               nCurPos     = Ftell( nHandle )
  3534.               nStartPos   = nCurPos
  3535.               nFlength    = Flen( nHandle )
  3536.               nBuffSize   = min( 254, nFlength )
  3537.  
  3538.               *-- Now start reading characters into the buffer
  3539.               do while nCurPos < nFlength
  3540.  
  3541.                  cBuffer = ""
  3542.  
  3543.                  do while len(cBuffer) < nBuffSize
  3544.  
  3545.                     cAddBuf = fread( nHandle, 1 )
  3546.  
  3547.                     *-- If you read in a null, replace it in the buffer
  3548.                     *-- by a space
  3549.                     if chr(0) = cAddBuf
  3550.  
  3551.                        cAddBuf = " "
  3552.  
  3553.                     endif
  3554.  
  3555.                     cBuffer = cBuffer + cAddBuf
  3556.  
  3557.                  enddo
  3558.  
  3559.                  if lWantUpper
  3560.  
  3561.                     cBuffer = upper(cBuffer)
  3562.  
  3563.                  endif
  3564.  
  3565.                  *-- See if the search string is in the buffer
  3566.                  nBufPos = at( cSearch, cBuffer )
  3567.  
  3568.                  *-- and if it is, store its position in the file
  3569.                  if nBufPos > 0
  3570.  
  3571.                     nFoundPos = nCurPos + nBufPos - 1
  3572.                     exit
  3573.  
  3574.                  endif
  3575.  
  3576.                  nCurPos = Ftell( nHandle )
  3577.  
  3578.               enddo
  3579.  
  3580.               if nFoundPos < 1
  3581.  
  3582.                  nJunk = fseek( nHandle, nStartPos, 0 )
  3583.  
  3584.               else
  3585.  
  3586.                  nJunk = fseek( nHandle, nFoundPos, 0 )
  3587.  
  3588.               endif
  3589.  
  3590.            endif
  3591.  
  3592. RETURN( nFoundPos )
  3593. *-- EoF: FLocate()
  3594.  
  3595. FUNCTION FTell
  3596. *-------------------------------------------------------------------------------
  3597. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3598. *-- Date........: 04/26/1993
  3599. *-- Notes.......: A shorthand way of finding the current position of the
  3600. *--               file pointer in a file, without moving the pointer.
  3601. *-- Written for.: dBASE IV, 1.5
  3602. *-- Rev. History: 04/26/1993  -- Original
  3603. *-- Calls.......: None
  3604. *-- Called by...: Any (specifically FLocate()).
  3605. *-- Usage.......: FTell(<nHandle>)
  3606. *-- Example.....: FTell(5)
  3607. *-- Returns.....: Current position of pointer in a file.
  3608. *-- Parameters..: nHandle  =  DOS file handle.
  3609. *-------------------------------------------------------------------------------
  3610.         parameters  nHandle
  3611.  
  3612. RETURN( fseek( nHandle, 0, 1 ) )
  3613. *-- EoF: FTell()
  3614.  
  3615. FUNCTION FLen
  3616. *-------------------------------------------------------------------------------
  3617. *-- Programmer..: Rose Vines (CIS: 100026,3153)
  3618. *-- Date........: 04/26/1993
  3619. *-- Notes.......: Finds length (in bytes) of a file and then returns
  3620. *--               the file pointer to byte 0.
  3621. *-- Written for.: dBASE IV, 1.5
  3622. *-- Rev. History: 04/26/1993  -- Original
  3623. *-- Calls.......: None
  3624. *-- Called by...: Any (specifically FLocate()).
  3625. *-- Usage.......: FLen(<nHandle>)
  3626. *-- Example.....: FLen(6)
  3627. *-- Returns.....: nLength   =  Length of file in bytes
  3628. *-- Parameters..: nHandle   =  DOS file handle
  3629. *-------------------------------------------------------------------------------
  3630.         parameters nHandle
  3631.         private nCurPos, nLength, xJunk
  3632.  
  3633.         *-- Locate current position in file without moving pointer
  3634.         nCurPos = Ftell( nHandle )
  3635.  
  3636.         *-- Find the length of the file by shifting the pointer to the end
  3637.         nLength = fseek( nHandle, 0, 2 )
  3638.  
  3639.         *-- Return the pointer to the original starting point
  3640.         nJunk   = fseek( nHandle, nCurPos, 0 )
  3641.  
  3642. RETURN( nLength )
  3643. *-- EoF: FLen()
  3644.  
  3645. FUNCTION FReadI32
  3646. *-------------------------------------------------------------------------------
  3647. *-- Programmer..: Borland
  3648. *-- Date........: 1992
  3649. *-- Notes.......: Convert a 4-byte integer to its decimal value.
  3650. *--               The UDF reads the next 4 bytes from a file and converts
  3651. *--               them to decimal.
  3652. *-- Written for.: dBASE IV, 1.5
  3653. *-- Rev. History: Original
  3654. *-- Calls.......: None
  3655. *-- Called by...: Any (specifically FindTagExp)
  3656. *-- Usage.......: FReadI32(<nHandle>)
  3657. *-- Example.....: FReadI32(4)
  3658. *-- Returns.....: nResult  =  Decimal value of next 4 bytes in file
  3659. *-- Parameters..: nHandle  =  DOS file handle
  3660. *-------------------------------------------------------------------------------
  3661.    parameters nHandle
  3662.    private nResult, nByte1, nByte2, nByte3, nByte4
  3663.  
  3664.    nResult = 0
  3665.    nByte1  = asc( fread( nHandle,1 ) )
  3666.    nByte2  = asc( fread( nHandle,1 ) ) * 256
  3667.    nByte3  = asc( fread( nHandle,1 ) ) * 256 * 256
  3668.    nByte4  = asc( fread( nHandle,1 ) ) * 256 * 256 * 256
  3669.    nResult = nByte1 + nByte2 + nByte3 + nByte4
  3670.  
  3671. RETURN (nResult)
  3672. *-- EoF: FReadI32()
  3673.  
  3674. *-------------------------------------------------------------------------------
  3675. *-- EoP: FILES.PRG
  3676. *-------------------------------------------------------------------------------
  3677.